C
C	$Id$
C
      INTEGER FUNCTION CSNEARND (P,IST,N,X,Y,Z,LIST,LPTR,
     .                         LEND, AL)
      INTEGER IST, N, LIST(*), LPTR(*), LEND(N)
      DOUBLE PRECISION P(3), X(N), Y(N), Z(N), AL
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/28/98
C
C   Given a point P on the surface of the unit sphere and a
C Delaunay triangulation created by Subroutine CSTRMESH, this
C function returns the index of the nearest triangulation
C node to P.
C
C   The algorithm consists of implicitly adding P to the
C triangulation, finding the nearest neighbor to P, and
C implicitly deleting P from the triangulation.  Thus, it
C is based on the fact that, if P is a node in a Delaunay
C triangulation, the nearest node to P is a neighbor of P.
C
C
C On input:
C
C       P = Array of length 3 containing the Cartesian coor-
C           dinates of the point P to be located relative to
C           the triangulation.  It is assumed without a test
C           that P(1)**2 + P(2)**2 + P(3)**2 = 1.
C
C       IST = Index of a node at which CSTRFIND begins the
C             search.  Search time depends on the proximity
C             of this node to P.
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       X,Y,Z = Arrays of length N containing the Cartesian
C               coordinates of the nodes.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to CSTRMESH.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       CSNEARND = Nodal index of the nearest node to P, or 0
C                if N < 3 or the triangulation data struc-
C                ture is invalid.
C
C       AL = Arc length (angular distance in radians) be-
C            tween P and CSNEARND unless CSNEARND = 0.
C
C       Note that the number of candidates for CSNEARND
C       (neighbors of P) is limited to LMAX defined in
C       the PARAMETER statement below.
C
C Modules required by CSNEARND:  CSJRAND, CSLSTPTR, CSTRFIND, CSSTORE
C
C Intrinsic functions called by CSNEARND:  ABS, ACOS
C
C***********************************************************
C
      INTEGER   CSLSTPTR
      INTEGER   LMAX
      PARAMETER (LMAX=25)
      INTEGER   I1, I2, I3, L, LISTP(LMAX), LP, LP1, LP2,
     .          LPL, LPTRP(LMAX), N1, N2, N3, NN, NR, NST
      DOUBLE PRECISION B1, B2, B3, DS1, DSR, DX1, DX2, DX3,
     .                 DY1, DY2, DY3, DZ1, DZ2, DZ3
C
C Local parameters:
C
C B1,B2,B3 =  Unnormalized barycentric coordinates returned
C               by CSTRFIND
C DS1 =       (Negative cosine of the) distance from P to N1
C DSR =       (Negative cosine of the) distance from P to NR
C DX1,..DZ3 = Components of vectors used by the swap test
C I1,I2,I3 =  Nodal indexes of a triangle containing P, or
C               the rightmost (I1) and leftmost (I2) visible
C               boundary nodes as viewed from P
C L =         Length of LISTP/LPTRP and number of neighbors
C               of P
C LMAX =      Maximum value of L
C LISTP =     Indexes of the neighbors of P
C LPTRP =     Array of pointers in 1-1 correspondence with
C               LISTP elements
C LP =        LIST pointer to a neighbor of N1 and LISTP
C               pointer
C LP1,LP2 =   LISTP indexes (pointers)
C LPL =       Pointer to the last neighbor of N1
C N1 =        Index of a node visible from P
C N2 =        Index of an endpoint of an arc opposite P
C N3 =        Index of the node opposite N1->N2
C NN =        Local copy of N
C NR =        Index of a candidate for the nearest node to P
C NST =       Index of the node at which CSTRFIND begins the
C               search
C
C
C Store local parameters and test for N invalid.
C
      NN = N
      IF (NN .LT. 3) GO TO 6
      NST = IST
      IF (NST .LT. 1  .OR.  NST .GT. NN) NST = 1
C
C Find a triangle (I1,I2,I3) containing P, or the rightmost
C   (I1) and leftmost (I2) visible boundary nodes as viewed
C   from P.
C
      CALL CSTRFIND (NST,P,N,X,Y,Z,LIST,LPTR,LEND, B1,B2,B3,
     .             I1,I2,I3)
C
C Test for collinear nodes.
C
      IF (I1 .EQ. 0) GO TO 6
C
C Store the linked list of 'neighbors' of P in LISTP and
C   LPTRP.  I1 is the first neighbor, and 0 is stored as
C   the last neighbor if P is not contained in a triangle.
C   L is the length of LISTP and LPTRP, and is limited to
C   LMAX.
C
      IF (I3 .NE. 0) THEN
        LISTP(1) = I1
        LPTRP(1) = 2
        LISTP(2) = I2
        LPTRP(2) = 3
        LISTP(3) = I3
        LPTRP(3) = 1
        L = 3
      ELSE
        N1 = I1
        L = 1
        LP1 = 2
        LISTP(L) = N1
        LPTRP(L) = LP1
C
C   Loop on the ordered sequence of visible boundary nodes
C     N1 from I1 to I2.
C
    1   LPL = LEND(N1)
          N1 = -LIST(LPL)
          L = LP1
          LP1 = L+1
          LISTP(L) = N1
          LPTRP(L) = LP1
          IF (N1 .NE. I2  .AND.  LP1 .LT. LMAX) GO TO 1
        L = LP1
        LISTP(L) = 0
        LPTRP(L) = 1
      ENDIF
C
C Initialize variables for a loop on arcs N1-N2 opposite P
C   in which new 'neighbors' are 'swapped' in.  N1 follows
C   N2 as a neighbor of P, and LP1 and LP2 are the LISTP
C   indexes of N1 and N2.
C
      LP2 = 1
      N2 = I1
      LP1 = LPTRP(1)
      N1 = LISTP(LP1)
C
C Begin loop:  find the node N3 opposite N1->N2.
C
    2 LP = CSLSTPTR(LEND(N1),N2,LIST,LPTR)
        IF (LIST(LP) .LT. 0) GO TO 3
        LP = LPTR(LP)
        N3 = ABS(LIST(LP))
C
C Swap test:  Exit the loop if L = LMAX.
C
        IF (L .EQ. LMAX) GO TO 4
        DX1 = X(N1) - P(1)
        DY1 = Y(N1) - P(2)
        DZ1 = Z(N1) - P(3)
C
        DX2 = X(N2) - P(1)
        DY2 = Y(N2) - P(2)
        DZ2 = Z(N2) - P(3)
C
        DX3 = X(N3) - P(1)
        DY3 = Y(N3) - P(2)
        DZ3 = Z(N3) - P(3)
        IF ( DX3*(DY2*DZ1 - DY1*DZ2) -
     .       DY3*(DX2*DZ1 - DX1*DZ2) +
     .       DZ3*(DX2*DY1 - DX1*DY2) .LE. 0.D0 ) GO TO 3
C
C Swap:  Insert N3 following N2 in the adjacency list for P.
C        The two new arcs opposite P must be tested.
C
        L = L+1
        LPTRP(LP2) = L
        LISTP(L) = N3
        LPTRP(L) = LP1
        LP1 = L
        N1 = N3
        GO TO 2
C
C No swap:  Advance to the next arc and test for termination
C           on N1 = I1 (LP1 = 1) or N1 followed by 0.
C
    3   IF (LP1 .EQ. 1) GO TO 4
        LP2 = LP1
        N2 = N1
        LP1 = LPTRP(LP1)
        N1 = LISTP(LP1)
        IF (N1 .EQ. 0) GO TO 4
        GO TO 2
C
C Set NR and DSR to the index of the nearest node to P and
C   an increasing function (negative cosine) of its distance
C   from P, respectively.
C
    4 NR = I1
      DSR = -(X(NR)*P(1) + Y(NR)*P(2) + Z(NR)*P(3))
      DO 5 LP = 2,L
        N1 = LISTP(LP)
        IF (N1 .EQ. 0) GO TO 5
        DS1 = -(X(N1)*P(1) + Y(N1)*P(2) + Z(N1)*P(3))
        IF (DS1 .LT. DSR) THEN
          NR = N1
          DSR = DS1
        ENDIF
    5   CONTINUE
      DSR = -DSR
      IF (DSR .GT. 1.0D0) DSR = 1.0D0
      AL = ACOS(DSR)
      CSNEARND = NR
      RETURN
C
C Invalid input.
C
    6 CSNEARND = 0
      RETURN
      END


	REAL FUNCTION INVTTAIL(p,n)
	USE MSIMSL
C
C    invttail(n,p)
C       Domain n:     2e-10 to 2e+17 (may be nonintegral)
C       Domain p:     0 to 1
C       Range:        -8e+307 to 8e+307
C       Description:  returns the inverse reverse cumulative (upper tail or survivor) Student's t distribution: if
C                         ttail(n,t) = p, then invttail(n,p) = t.

	real n
	real p

	invttail=abs(tin(p,n))
C
C    Return.
C
	RETURN
	END


C++***************************************************************
C Program to compute the square of each pixel value of an image:
C
C Syntax:
C       RUNS SQUARE_IMAGE IN OUT
C Exemple:
C       RUNS SQUARE_IMAGE TEST SQRT_TEST
C
C JLP
C Version of 08-01-93
C--***************************************************************
	PROGRAM SQUARE_IMAGE
	INTEGER*4 PNTR_IMAGE,MADRID(1)
	INTEGER NX,NY,IFMT_IN,IFMT_OUT
	CHARACTER SYMBOL*20,BUFFER*40,NAME*40,COMMENTS*80
	COMMON /VMR/MADRID

C To get the possibility of command line
	CALL JLP_BEGIN
C
        WRITE (6,45)
45	FORMAT(' Program SQUARE_IMAGE, Version 08-01-93')

C Inquire the format (input/output) :
	CALL JLP_INQUIFMT

C Input :
        WRITE(6,*) 'Input file: '
        READ(5,10) NAME
	CALL JLP_VM_READIMAG(PNTR_IMAGE,NX,NY,NAME,COMMENTS)

C Compute square root:
	CALL SQUARE_IMA(MADRID(PNTR_IMAGE),MADRID(PNTR_IMAGE),NX,NY,NX)

C Output :
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
        PRINT *,' Comments: ',COMMENTS
	CALL JLP_WRITEIMAG(MADRID(PNTR_IMAGE),NX,NY,NX,
     1	NAME,COMMENTS)

	CALL JLP_END
	STOP
	END
C***************************************************************
C
C***************************************************************
	SUBROUTINE SQUARE_IMA(IN,OUT,NX,NY,IDIM)
        INTEGER*4 NX,NY,IDIM,IX,IY
	REAL*4 IN(IDIM,*),OUT(IDIM,*),WORK

C Main loop:
        DO IY=1,NY
          DO IX=1,NX
             OUT(IX,IY)=IN(IX,IY)*IN(IX,IY)
          END DO
        END DO

	RETURN
	END


!---------------------------------------------------------------------------------
!Author: Matias Pablo, Borghi Orue
!Title: 2D Monte Carlo simulation of the Modified Ising Model
!Version: 3
!Comments:  $ gfortran ranmar_seed.f95 subroutines.f95 kawasaki.f95 -o runv1
!DynamicLattice: $./runv1 | ./dllinux.exe -1 -nx 20 -ny 20 -grid -z -1 1
!INPUTS: ConfigurationFile
!OUTPUTS: Three dat files: 'Magnetization30L.dat', 'Energy30L.dat' and 'Inter.dat'
!----------------------------------------------------------------------------------
program kawasaki

use subroutines
use rm
use iso_fortran_env
implicit none

	integer, parameter :: dp = selected_real_kind(15, 307) !For double precision
	integer::nrows,ncols,iniseed
	integer::average
	integer::posx,posy,newposx,newposy,dim
	real::npos,nneg,nnull !Sum of thes values = 1
	real::probpos,probneg,probnull !Probability of picking a positive spin
	real::extMagField
	integer(kind=int64):: MCS, EquilSteps,exchangeCounter = 0!, NumofTempPoints
	integer(kind=int64):: i,j!,indexTemp !Dummy indeces
	integer::k,printOPT,spinDyn,pointStart
	integer :: index1, index2,index3
	integer::exchangeSpin,matrizInv
	integer,allocatable::matriz(:,:)
	integer,allocatable::ip(:),im(:)
	integer::promediateCounter
	integer::counter,t,alfa,prob
	real,allocatable::alpha(:,:)
	real::alpha11,alpha13,alpha33
	logical::cond
	!Type interaction v2:  4N values
	!integer::interPos,interNeg,interPN
	!real,allocatable::rIdeal(:),rMeasured(:),rho(:)
	!real::rIdeal,rMeasured,rho
	real::energia
	real::rvec(1)
	real:: magnetWhite,magnetBlack,antiMagnet,Magnetizacion
	integer::white,black
	real(dp)::magnetAbsFerroINI=0.0,magnetFerroINI=0.0,magnetFerro2INI=0.0,magnetFerro4INI=0.0,EnergyINI=0.0,Energy2INI=0.0
	real(dp)::magnetAntiINI=0.0,magnetAnti2INI=0.0,magnetAnti4INI=0.0
	real(dp),allocatable:: Energy(:),Energy2(:),magnetAnti(:),magnetAnti2(:),magnetAnti4(:)
	real(dp),allocatable:: magnetAbsFerro(:),magnetFerro(:),magnetFerro2(:),magnetFerro4(:)
	real(dp),dimension(20)::DeltaE
	real(dp)::Delta_E
	real::currentTemp,beta
	real::invDim
	character(len=100):: MagFile,folderName,FileOutput='OutputFile.log',currentOutput='currentStatus.log'
	logical::dir_e
	character(len=10):: stringL,stringTemp,stringAlpha

	!real,allocatable::temps(:) !19
	!real::TempMax=6,TempMin=1,step=0.1
	!real::temps(20) = (/0.02252,0.02254,0.02256,0.02258,0.02262,0.02264,0.02266,0.02268,0.02272,0.02274,0.02276,0.02278,0.02282,0.02284,0.02286,0.02288,0.02292,0.02294,0.02296,0.02298/)
	real::temps(1) = (/2.38/)
	real::alphaVals(1) = (/1/) !21
	real::posDsty(1) =(/0.5/) !6
	real :: inimagnet=1.0

	ncols = 20
	nrows = ncols

	!print *, '# of temperature values = ', int( (TempMax-TempMin)/real(step) )
	!allocate( temps( int( (TempMax-TempMin)/real(step) ) ) )
	!do t = 1, int( (TempMax-TempMin)/real(step) )
	!	temps(t) = TempMax - step*t
	!	print *, temps
	!end do
	!print *,temps
	!temps = (/ 0.5,0.7,0.9,1.0,1.1,1.3,1.6,2.0,2.3,2.5,3.0/)
	!temps = (/1.0/)

	!alphaVals = (/3.0,2.9,2.8,2.7,2.6,2.5,2.4,2.3,2.2,2.1,2.0,1.9,1.8,1.7,1.6,1.5,1.4,1.3,1.2,1.1,1.0 /)
	!alphaVals = (/-0.9,-0.8,-0.7,-0.6,-0.5,-0.4,-0.3,-0.2,-0.1,0.0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9 /)
	!alphaVals = (/-1.0 /)

	!posDsty = (/ 0.2,0.3,0.4,0.5,0.6,0.7/)
	!posDsty =(/0.5/)
	!print *, 'dim = ',size(temps)
	!do t = 1,size(temps)
	!	print*, 'Element ',t,'Value = ',temps
	!end do
	! Read in input parameters from file "ising.in"
	open(unit=11,file="ConfigurationFile",status="old",action="read")
	read(11,*);read(11,*) printOPT
	read(11,*);read(11,*) spinDyn
	read(11,*);read(11,*) iniseed
	read(11,*);read(11,*) probpos
	read(11,*);read(11,*) probneg
	read(11,*);read(11,*) MCS
	read(11,*);read(11,*) EquilSteps
	read(11,*);read(11,*) pointStart
	read(11,*);read(11,*) average
	read(11,*);read(11,*) alpha11
	read(11,*);read(11,*) alpha33
	read(11,*);read(11,*) extMagField
	close(11)

	! Allocate the space for some important quantities.
	allocate(matriz(nrows,ncols))
	allocate(alpha(3,3))

	!Needs to be improved. Now it is made for square lattices
	allocate(im(nrows))
	allocate(ip(nrows))

	allocate(magnetAbsFerro(MCS))
	allocate(magnetFerro(MCS))
	allocate(magnetFerro2(MCS))
	allocate(magnetFerro4(MCS))
	allocate(Energy(MCS))
	allocate(Energy2(MCS))
	allocate(magnetAnti(MCS))
	allocate(magnetAnti2(MCS))
	allocate(magnetAnti4(MCS))

	!allocate(rIdeal(average))
	!allocate(rMeasured(average))
	!allocate(rho(average))

	!Fill ip & im arrays
	do i = 1,nrows
		ip(i) = i+1
		im(i) = i-1
	end do
	ip(nrows) = 1
	im(1) = nrows

	if (inimagnet /= 0.0 .AND. inimagnet/=1.0) then
		!npos = int(nrows**2/2.0 + inimagnet * nrows**2)
		!nneg = nrows**2 - npos
		nneg = int(nrows**2*((1-inimagnet)/real(2.0)))
		npos = nrows**2 - nneg
		!print *, 'inimagnet Neither 0 nor 1'
		!print *, 'npos = ',npos,' nneg= ',nneg
	else if(inimagnet == 0.0) then
		npos = int(nrows**2/2.0)
		nneg = npos
		!print *, 'inimagnet = 0'
		!print *, 'npos = ',npos,' nneg= ',nneg
	else !inimagnet==1.0
		npos= int(nrows**2)
		nneg=0
		!print *, 'inimagnet = 1'
		!print *, 'npos = ',npos,' nneg= ',nneg
	end if

	!Create the folder name
	!Cast integer/real to string
	write(stringL,'(I3.3)') nrows

	dim = nrows*ncols
	folderName = 'L='//trim(stringL)
	inquire(FILE=trim(folderName)//'/.', EXIST=dir_e)
	!print *, .FALSE. .EQV. dir_e
	!call exit(0)
	if(.FALSE. .EQV. dir_e) then !Create the folder if it does not exists
		call system('mkdir -p ' // trim(folderName) )
	end if
	!folderName = 'L='//trim(stringL)//'/'//trim(totalOutput)

!	open(unit=20,file=trim(folderName)//'/'//trim(currentOutput),status="replace",action="write")
!	close(20)
!	open(unit=1,file=trim(folderName)//'/'//trim(FileOutput),status="replace",action="write")
!	close(1)

	write(stringTemp,'(F7.4)') temps(1)
	write(stringAlpha,'(F7.2)') alphaVals(1)
	MagFile = 'a='//trim(stringAlpha)//'T='//trim(stringTemp)//'.dat'
	call StripSpaces(MagFile)

!	open(unit=20,file=trim(folderName)//'/'//trim(currentOutput),access="append",action="write")
	!Determine the number of holes and check for erros

	!MCS = dim*10
	!EquilSteps = int (0.5*MCS)

!	write(20,*) 'Parameters in this simulation'
!	write(20,*) 'L=',nrows
	!write(20,*) 'Temps=',temps
!	write(20,*) 'Alphadd=',alpha11,' ','Alphauu=',' ',alpha33
	!write(20,*) 'Alphaud=', alphaVals
	!write(20,*) 'N+=',posDsty
!	write(20,*) 'p+=',probpos
!	write(20,*) 'MCS=',MCS
!	write(20,*) 'aver=',average

!	close(20)

	!open (UNIT=1, FILE=trim(folderName)//'/'//trim(FileOutput),ACTION='write',STATUS='replace')
	!	write(1,*) "Alfa,posDsty,Temperatura,Energia,Cv,magnetAnti,SusceptAnti,cumulantAnti,magnetFerro,SusceptFerro,cumulantFerro"
	!close(1)
	do alfa = 1,size(alphaVals)
	!	open(unit=20,file=trim(folderName)//'/'//trim(currentOutput),access="append",action="write")
	!		write(20,'(A,F4.1)') 'At alfa= ',alphaVals(alfa)
	!	close(20)
		!Ini alpha
		!call ini_alpha(alpha,alpha11,alphaVals(alfa),alpha33)
		alpha(1,1) = 1
		alpha(1,3) = alphaVals(1)
		alpha(3,1) = alphaVals(1)
		alpha(3,3) = 1
		!Initialize some variables to zero
		!call SetToZeroVariables(Energy,Energy2,magnetAnti,magnetAnti2,magnetAnti4,magnetFerro,magnetFerro2,magnetFerro4,size(temps))

	do t=1,size(temps)
	!	if (k==1 ) then
	!	open(unit=20,file=trim(folderName)//'/'//trim(currentOutput),access="append",action="write")
			!write(*,*) 'At T=',temps(t)
	!	close(20)
	!	end if
	beta = 1.0/real(temps(t))

	Energy(:) = 0.0
	Energy2(:) = 0.0
	magnetAnti(:) = 0.0
	magnetFerro(:) = 0.0
	magnetAbsFerro(:) = 0.0
	magnetAnti2(:) = 0.0
	magnetAnti4(:) = 0.0
	magnetFerro2(:) = 0.0
	magnetFerro4(:) = 0.0
	EnergyINI = 0.0
	Energy2INI = 0.0
	magnetAntiINI = 0.0
	magnetAnti2INI = 0.0
	magnetAnti4INI = 0.0
	magnetFerroINI = 0.0
	magnetFerro2INI = 0.0
	magnetFerro4INI = 0.0
	magnetAbsFerroINI = 0.0
	!write(2,*) "Current Temperature T = ", temps,"beta = ",beta
	!print *, 'npoints: ',npoints
	!close(20) !Closing OutputFile.dat
	!Define the values of DeltaE knowing the Temperature
	!Only two possible values
	! 1) DeltaE(1) = exp(-4/Temp)
	! 2) DeltaE(2) = exp(-8/Temp)
	!call Inicializacion_DeltaE(DeltaE,temps)
	do k = 1,average

		!with spin-up initial values
		!call ini_matriz(matriz,nrows,ncols,iniseed,k)
		!do i=1,ncols
		!	do j = 1,nrows
		!		if (ran1(5) < 0.5) then
		!			matriz(i,j) = 1
		!		else
		!			matriz(i,j) = -1
		!		end if
		!	end do
		!end do
		do index1=1,ncols
			do index2 = 1,nrows
				matriz(index1,index2) = 1
			end do
		end do

		!Now increment the number of nneg
		index3 = nneg
		!If k=0 then m=1
		!If k=1 o
		do while (index3 /= 0)
			!Return a random position in matrix and flip it if its not already a down spin
			index1 = nint( (ncols-1) * ran1(5) ) + 1
			index2 = nint( (nrows-1) * ran1(5) ) + 1
			if (matriz(index1,index2) == 1) then
				matriz(index1,index2) = -1
				index3 = index3 - 1
			end if
		end do
		! **********QUANTITIES AT t=0 *************
		energia = 0.0
		magnetWhite = 0.0
		magnetBlack = 0.0
		white = 0
		black = 0
		antiMagnet = 0.0
		do index1 = 1,nrows
		do index2 = 1,ncols
			energia = energia &
			- matriz(index1,index2)*( matriz(ip(index1),index2) * alpha(matriz(index1,index2)+2 , matriz(ip(index1),index2)+2) &
			+ matriz(im(index1),index2) * alpha(matriz(index1,index2)+2 , matriz(im(index1),index2)+2) &
			+ matriz(index1,ip(index2)) * alpha(matriz(index1,index2)+2 , matriz(index1,ip(index2))+2) &
			+ matriz(index1,im(index2)) * alpha(matriz(index1,index2)+2 , matriz(index1,im(index2))+2) )
		!print *, 'DeltaE: ',Delta_E
			if ( (mod(index1,2) == 0 .AND. mod(index2,2) == 0) .OR.(mod(index1,2) /= 0 .AND. mod(index2,2) /= 0) ) then
				magnetBlack = magnetBlack + matriz(index1,index2)
				black = black + 1
			else
				magnetWhite = magnetWhite + matriz(index1,index2)
				white = white + 1
			end if
		enddo
		enddo
		energia = energia/real(2)!(2.0*ncols*nrows)
		EnergyINI = EnergyINI + energia
		Energy2INI = Energy2INI + energia**2
		!print *, 'Energy: ',energia, 'Energy2: ',energia**2

		!-----AntiFerro quantities----------------
		!<mB>
		magnetBlack = magnetBlack / real(black)
		!<mW>
		magnetWhite = magnetWhite / real(white)
		!inter
		antiMagnet = abs(magnetBlack - magnetWhite) / real(2)
		!<mANTI>
		magnetAntiINI = magnetAntiINI + antiMagnet

		magnetAnti2INI = magnetAnti2INI + antiMagnet**2

		magnetAnti4INI = magnetAnti4INI + antiMagnet**4
		!------------------------------------------------
		!------------------------------------------------
		Magnetizacion = sum(matriz(1:ncols,1:nrows))!/real(dim)
		!<m>F
		magnetFerroINI = magnetFerroINI + Magnetizacion

		magnetAbsFerroINI = magnetAbsFerroINI + abs(Magnetizacion)

		magnetFerro2INI = magnetFerro2INI + Magnetizacion**2

		magnetFerro4INI = magnetFerro4INI + Magnetizacion**4

		!Initialize the matrix
		!call WriteSpinConf(matriz,nrows,ncols)
		!Write initial spin configurations in screen for DynamicLattice

		!call CountPosNeg(matriz,nrows,ncols,npos,nneg,nnull)
		!promediateCounter = 0
		!Choose a random point (posx,posy) where we begin calculating

		!Spinflip it is not done with probpos or probneg because of the dissipation of the spins. At low temperature
		!npos or nneg -> 0 so it is not possible to select spins with the requiered probability.

		!Sum over one MonteCarlo time //dim = 1MC
		!Sum over A MonteCarlo time: A*dim
		!In the next loop we flip a sping according to some conditions
		do i=1,MCS

			!if (mod(i,MCS/10) == 0) then
				!print *, 'Current step: ',i,'/',MCS
				!do index1 = 1,ncols
				!do index2 = 1,nrows
				!write(*,*) index1,index2,matriz(index1,index2)
				!enddo
				!enddo
			!end if

			do j = 1, dim

				!call elegir_sitio_SpinFlip(nrows,ncols,posx,posy,iniseed,k)
				posx = nint( (ncols-1) * ran1(5) ) + 1
				posy = nint( (nrows-1) * ran1(5) ) + 1

				!Calculate DeltaE for a given point (posx,posy)
				!print *,im(1),i,j,posx,posy

				!call CalcDeltaEnergySpinFlip(nrows,ncols,posx,posy,matriz,Delta_E,ip,im,alpha)
				matrizInv = -matriz(posx,posy)

				Delta_E = -matrizInv* &
				( matriz(ip(posx),posy)*alpha(matrizInv+2,matriz(ip(posx),posy)+2) &
				+ matriz(im(posx),posy)*alpha(matrizInv+2,matriz(im(posx),posy)+2) &
			    + matriz(posx,ip(posy))*alpha(matrizInv+2,matriz(posx,ip(posy))+2) &
			    + matriz(posx,im(posy))*alpha(matrizInv+2,matriz(posx,im(posy))+2) ) &
				+ matriz(posx,posy)* &
				( matriz(ip(posx),posy)*alpha(matriz(posx,posy)+2,matriz(ip(posx),posy)+2) &
				+ matriz(im(posx),posy)*alpha(matriz(posx,posy)+2,matriz(im(posx),posy)+2) &
			    + matriz(posx,ip(posy))*alpha(matriz(posx,posy)+2,matriz(posx,ip(posy))+2) &
			    + matriz(posx,im(posy))*alpha(matriz(posx,posy)+2,matriz(posx,im(posy))+2) )

				!print *, 'DeltaE: ',Delta_E
				if (-beta*Delta_E > dlog( ran1(5)+1.0d-10 ) )then
					matriz(posx,posy) = -matriz(posx,posy)
				end if

!				if (Delta_E <= 0) then
!					matriz(posx,posy) = -matriz(posx,posy)
!				else
!					call ranmar(rvec,1,iniseed*average)
!					if (Delta_E == int(Delta_E) .AND. Delta_E<=20) then
!						if (rvec(1) < DeltaE(int(Delta_E))) then
!								matriz(posx,posy) = -matriz(posx,posy)
!						end if
!					else
!						if ( rvec(1) < exp(-beta*Delta_E ) ) then
!							matriz(posx,posy) = -matriz(posx,posy)
!						end if
!					end if
!				end if

				!call elegir_sitio_SpinFlip(nrows,ncols,posx,posy,iniseed,k)

				!----------------------------------------------------------------
			end do !End loop dim
		!Calculate the Magnetization and Energy after equilibrium
			!if ( i > EquilSteps) then !mod(i,MCS/npoints) == 0
				!print *,'Enter at time: ',i,'for ',promediateCounter+1
				!promediateCounter = promediateCounter + 1

				!call calculationsInEquilibrium (nrows,ncols,matriz,alpha,ip,im,temps,&
				!	Energy,Energy2,k,extMagField,magnetAnti,magnetAnti2,magnetAnti4,&
				!	magnetFerro,magnetFerro2,magnetFerro4)
				energia = 0.0
				magnetWhite = 0.0
				magnetBlack = 0.0
				white = 0
				black = 0
				antiMagnet = 0.0
				do index1 = 1,nrows
				do index2 = 1,ncols
					energia = energia &
					- matriz(posx,posy)*( matriz(ip(posx),posy) * alpha(matriz(posx,posy)+2 , matriz(ip(posx),posy)+2) &
					+ matriz(im(posx),posy) * alpha(matriz(posx,posy)+2 , matriz(im(posx),posy)+2) &
	    			+ matriz(posx,ip(posy)) * alpha(matriz(posx,posy)+2 , matriz(posx,ip(posy))+2) &
	    			+ matriz(posx,im(posy)) * alpha(matriz(posx,posy)+2 , matriz(posx,im(posy))+2) )
				!print *, 'DeltaE: ',Delta_E
					if ( (mod(index1,2) == 0 .AND. mod(index2,2) == 0) .OR.(mod(index1,2) /= 0 .AND. mod(index2,2) /= 0) ) then
						magnetBlack = magnetBlack + matriz(index1,index2)
						black = black + 1
					else
						magnetWhite = magnetWhite + matriz(index1,index2)
						white = white + 1
					end if
				enddo
				enddo
				energia = energia/real(2.0)!/(2.0*ncols*nrows)
				Energy(i) = Energy(i) + energia
				Energy2(i) = Energy2(i) + energia**2
				!print *, 'Energy: ',energia, 'Energy2: ',energia**2

				!-----AntiFerro quantities----------------
				!<mB>
				magnetBlack = magnetBlack / real(black)
				!<mW>
				magnetWhite = magnetWhite / real(white)
				!inter
				antiMagnet = abs(magnetBlack - magnetWhite) / real(2)
				!<mANTI>
				magnetAnti(i) = magnetAnti(i) + antiMagnet

				magnetAnti2(i) = magnetAnti2(i) + antiMagnet**2

				magnetAnti4(i) = magnetAnti4(i) + antiMagnet**4
				!------------------------------------------------
				!------------------------------------------------
				Magnetizacion = sum(matriz(1:ncols,1:nrows))!/real(dim)
				!<m>F
				magnetFerro(i) = magnetFerro(i) + Magnetizacion

				magnetAbsFerro(i) = magnetAbsFerro(i) + abs(Magnetizacion)

				magnetFerro2(i) = magnetFerro2(i) + Magnetizacion**2

				magnetFerro4(i) = magnetFerro4(i) + Magnetizacion**4

				!Store the time desired to measure. They are not equidistant, so we need to do this
				!call WriteSpinConf(matriz,nrows,ncols)
			!end if

		end do !End loop of the MC steps
	invDim = 1.0/real(nrows*ncols*k)
	open(unit=1,file=trim(folderName)//'/'//trim(MagFile),status="replace",action="write")
	write(1,*) "average MCS AbsMagnetization Magnetization Magnetization2 Magnetization4 antiMagnetization antiMagnetization2 antiMagnetization4 Energy Energy2"
	write(1,'(I6,x,I6,x,F12.6,x,F12.6,x,F16.6,x,F16.6,x,F9.6,x,F9.6,x,F9.6,x,F9.6,x,F16.6)') k,0+1,magnetAbsFerroINI*invDim,(magnetFerroINI)*invDim,magnetFerro2INI,magnetFerro4INI*invDim,magnetAntiINI*invDim,magnetAnti2INI,magnetAnti4INI*invDim,EnergyINI*invDim,Energy2INI*invDim
	do j = 1,MCS
		write(1,'(I6,x,I6,x,F12.6,x,F12.6,x,F16.6,x,F16.6,x,F9.6,x,F9.6,x,F9.6,x,F9.6,x,F16.6)') k,j+1,magnetAbsFerro(j)*invDim,magnetFerro(j)*invDim,magnetFerro2(j)*invDim,magnetFerro4(j)*invDim,magnetAnti(j)*invDim,magnetAnti2(j),magnetAnti4(j)*invDim,Energy(j)*invDim,Energy2(j)*invDim
	end do
	close(1)
	end do ! End loop of averages

	end do ! End loop of temperatures

!	open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),access='append',action='write')
!		write(2,*) 'Accepted = ', exchangeCounter/real(MCS*dim*average)
!	close(2)

	!Write the results in a file
	!call Write2File(Energy,Energy2,magnetAnti,magnetAnti2,magnetAnti4,magnetFerro,magnetFerro2,magnetFerro4,promediateCounter,average,temps,size(temps),alphaVals(alfa),posDsty(prob),folderName,FileOutput)
end do !End loop of alpha vals
end program kawasaki

V6 Out-Of & On Equilibrium/V6.8 FSS/Mejorado/kawasaki.f95


! Copyright (c) 2012, Johannes Feist
! licensed under the MIT open source license, see LICENSE file

module laserfields_miscfuncs
  use nrtype
  implicit none

  !> 1-dimensional polynomial interpolation
  interface interpolate
     module procedure interpolate_single
     module procedure interpolate_array
  end interface
  private interpolate_array, interpolate_single

  !> convert real or complex numbers to strings that can be used in gnuplot
  interface gnuplotstring
     module procedure gnuplotstring_d
     module procedure gnuplotstring_z
  end interface
  private gnuplotstring_d, gnuplotstring_z
contains
  !---------------------------------------------------------------------------
  function get_unused_unit() result(unit)
    integer :: unit
    logical :: opened
    ! find an unused unit to use
    unit = 16
    opened = .true.
    do while (opened)
       unit = unit + 1
       inquire(unit=unit,opened=opened)
    end do
  end function get_unused_unit
  !----------------------------------------------------------------------
  !> obtain the phase (=argument) of a complex number
  real(dp) pure elemental function phase(c)
    complex(dpc), intent(in) :: c
    phase = atan2(aimag(c),real(c))
  end function phase
  !---------------------------------------------------------------------------
  !> return a complex number containing absolute value squared and phase
  !> as real and imaginary part: {|c|2,phase(c)}
  complex(dpc) pure elemental function abs2_phase(c)
    complex(dpc), intent(in) :: c
    abs2_phase = cmplx(abs(c)**2,phase(c),dpc)
  end function abs2_phase
  !---------------------------------------------------------------------------
  !> converts a double to a character string for gnuplot
  character(15) function gnuplotstring_d(val) result(ch)
    real(dp), intent(in) :: val
    write(ch,'(sp,es15.8)') val
  end function gnuplotstring_d
  !---------------------------------------------------------------------------
  !> converts a double complex to a character string for gnuplot
  character(33) function gnuplotstring_z(val) result(ch)
    complex(dpc), intent(in) :: val
    write(ch,'(sp,a,es15.8,a,es15.8,a)') '{',real(val),',',aimag(val),'}'
  end function gnuplotstring_z
  !---------------------------------------------------------------------------
  !> for a set of known values (x_old,f_old) calculate the value of f(x) at
  !> point x_new using polynomial interpolation
  real(dp) function interpolate_single(x_old,f_old,x_new,degree) result(f_new)
    real(dp), dimension(:), intent(in) :: x_old,f_old
    real(dp), intent(in) :: x_new
    !> order of the interpolating polynomial
    integer, intent(in) :: degree
    real(dp), dimension(1) :: x_new_arr, f_new_arr
    x_new_arr(1) = x_new
    f_new_arr = interpolate(x_old,f_old,x_new_arr,degree)
    f_new = f_new_arr(1)
  end function interpolate_single
  !---------------------------------------------------------------------------
  !> for a set of known values (x_old,f_old) calculate the values of f(x) at
  !> points x_new using polynomial interpolation
  function interpolate_array(x_old,f_old,x_new,degree) result(f_new)
    real(dp), dimension(:), intent(in) :: x_old, f_old, x_new
    real(dp), dimension(size(x_new)) :: f_new
    !> order of the interpolating polynomial
    integer, intent(in) :: degree
    integer :: ii, npoints_old, npoints_new, nearest_node, spoint, npoints_int

    if (size(x_old)/=size(f_old)) STOP 'ERROR: number of nodes and function values do not agree in interpolate!'

    npoints_new = size(x_new)
    npoints_old = size(x_old)
    ! number of points used for interpolation
    npoints_int=degree+1

    do ii = 1, npoints_new
       if (x_new(ii) < x_old(1) .or. x_new(ii) > x_old(npoints_old)) then
          STOP 'ERROR: extrapolation would be necessary in interpolate!'
       end if

       ! get nearest node smaller then x_new(ii)
       nearest_node = binary_search(x_old,x_new(ii))
       ! get starting point for interpolation
       spoint = min(max(nearest_node-(npoints_int-1)/2,1),npoints_old+1-npoints_int)
       ! call interpolation routine
       f_new(ii) = lagrange_interpol(x_old(spoint:spoint+degree),f_old(spoint:spoint+degree),npoints_int,x_new(ii))
    end do
  end function interpolate_array
  !-----------------------------------------------------------------------
  !> lagrange polynomial interpolation, using the barycentric form (see e.g. wikipedia)
  real(dp) pure function lagrange_interpol(xk,yk,n,x) result(y)
    !> size of xk and yk.
    integer, intent(in) :: n
    !> x-values of points to interpolate.
    real(dp), intent(in) :: xk(n)
    !> y-values of points to interpolate.
    real(dp), intent(in) :: yk(n)
    !> position at which to evaluate the interpolating polynomial.
    real(dp), intent(in) :: x
    real(dp) :: wk(n), nom, denom, diff
    integer :: ii, jj
    do jj = 1, n
       wk(jj) = 1
       do ii = 1, n
          if (ii/=jj) wk(jj) = wk(jj) / (xk(jj)-xk(ii))
       end do
    end do
    nom = 0
    denom = 0
    do jj = 1, N
       diff = abs(x-xk(jj))
       ! this guards against x=xk(jj)=0
       if (diff/=0) diff = 2*diff / (abs(x)+abs(xk(jj)))
       if (diff < 1.e-12) then
          y = yk(jj)
          return
       end if
       nom   = nom   + wk(jj)*yk(jj) / (x - xk(jj))
       denom = denom + wk(jj)        / (x - xk(jj))
    end do
    y = nom/denom
  end function lagrange_interpol
  !-----------------------------------------------------------------------
  !> do a binary search and return index il for which xs(il) <= x <= xs(il+1)
  pure integer function binary_search(xs,x) result(il)
    !> input array to search, has to be sorted (either in ascending or descending order)
    real(dp), intent(in) :: xs(:)
    !> value to search for
    real(dp), intent(in) :: x
    integer :: n, im, iu
    logical :: increasing

    n = size(xs)
    ! we do not check whether the sequence is actually monotonic, but we handle increasing and decreasing sequences
    increasing = xs(1) < xs(n)

    if (increasing) then
       if      (x < xs(1)) then; il = 1; return
       else if (x > xs(n)) then; il = n; return
       end if
    else
       if      (x > xs(1)) then; il = 1; return
       else if (x < xs(n)) then; il = n; return
       end if
    end if

    il=0   ! initial value for lower border
    iu=n+1 ! initial value for upper border
    do while (iu-il>1)
       im=(iu+il)/2
       if (increasing.eqv.(x > xs(im))) then
          il=im
       else
          iu=im
       end if
    end do
  end function binary_search
  !-----------------------------------------------------------------------
end module laserfields_miscfuncs


PROGRAM TestQuad

  use timers
  type(TimerType) :: func1Time,func2Time,func3Time

  REAL*8 left, right, result, eps, Quad
  REAL*8     Func1, Func2, Func3
  EXTERNAL   Func1, Func2, Func3

!     Initialise timers
  call TimerCreate(func1Time,"Func1")
  call TimerCreate(func2Time,"Func2")
  call TimerCreate(func3Time,"Func3")

  call TimerOn(func1Time)
  left  = 0.0
  right = 1.0
  eps   = 1.0E-7
  result = Quad (Func1, left, right, eps)
  call TimerOff(func1Time)

  PRINT *, "Result for Func1 = ", result
  call TimerPrint(func1Time)

  call TimerOn(func2Time)
  left  = 0.0
  right = 1.0
  eps   = 1.0E-7
  result = Quad (Func2, left, right, eps)
  call TimerOff(func2Time)

  PRINT *, "Result for Func2 = ", result
  call TimerPrint(func2Time)

  call TimerOn(func3Time)
  left  = 0.0
  right = 1.0
  eps   = 1.0E-7
  result = Quad (Func3, left, right, eps)
  call TimerOff(func3Time)

  PRINT *, "Result for Func3 = ", result
  call TimerPrint(func3Time)

END PROGRAM TestQuad

REAL*8 FUNCTION Quad (Func, left, right, epsilon)
  REAL*8 left, right, epsilon, Func

! *** Adaptive Quadrture

  INTEGER STACKSIZE,IL,IR,IE
  PARAMETER (STACKSIZE = 10000,IL=1,IR=2,IE=3)

  REAL*8 stack  (3,STACKSIZE)
  INTEGER stackpointer

  REAL*8 result, abserror, l, r, m, est1, est2, eps

  stackpointer = 1
  stack(il,stackpointer) = left
  stack(ir,stackpointer) = right
  stack(ie,stackpointer) = epsilon

  result = 0.0

  call Stackops(stackpointer,stack,result,Func)

  Quad = result

  RETURN
END FUNCTION Quad

SUBROUTINE Stackops(stackpointer,stack,result,Func)

  INTEGER STACKSIZE,IL,IR,IE
  PARAMETER (STACKSIZE = 10000,IL=1,IR=2,IE=3)

  REAL*8 stack(3,STACKSIZE)
  INTEGER stackpointer

  REAL*8 result, Func
  REAL*8 abserror, l, r, m, est1, est2, eps

  INTEGER active_threads, work

  active_threads = 0
  work = 0

!$OMP parallel default(none) shared(result, stack, stackpointer, active_threads) private(abserror, l, r, m, est1, est2, eps, work)
10  DO WHILE  (stackpointer .GE. 1 .OR. active_threads .NE. 0)

! *** Pop next interval off stack.
!$OMP critical (pop)
     IF (stackpointer .EQ. 0) THEN
        work = 0
     ELSE
        active_threads = active_threads + 1
        l   = stack(il,stackpointer)
        r   = stack(ir,stackpointer)
        eps = stack(ie,stackpointer)
        stackpointer = stackpointer - 1
        work = 1
     END IF
!$OMP END critical (pop)

IF (work .EQ. 0) THEN
   goto 10
END IF

! *** Compute estimates.

     m    = 0.5 * (l + r)
     est1 = 0.5 * (r - l) * (Func(l) + Func(r))
     est2 = 0.5 * ((m - l) * (Func(l) + Func(m)) + &
            (r - m) * (Func(m) + Func(r)))
     abserror = ABS(est2-est1) / 3.0

! *** Check for desired accuracy: push both halves onto the
! *** stack if not accurate enough.

     IF (abserror .LE. eps) THEN
! *** ours
!$OMP critical (resultCalc)
        result = result + est2
        active_threads = active_threads - 1
!$OMP END critical (resultCalc)
! *** ours
     ELSE
        IF (stackpointer+2 .GT. STACKSIZE) THEN
           PRINT *, "Stack too small, try STACKSIZE = ", 2*STACKSIZE
           STOP
        END IF

! *** ours
!$OMP critical (push)
! *** ours
        stackpointer = stackpointer + 1
        stack(il,stackpointer) = l
        stack(ir,stackpointer) = m
        stack(ie,stackpointer) = eps * 0.5

        stackpointer = stackpointer + 1
        stack(il,stackpointer) = m
        stack(ir,stackpointer) = r
        stack(ie,stackpointer) = eps * 0.5
! *** ours
        active_threads = active_threads - 1
!$OMP END critical (push)
! *** ours

     END IF
  END DO
!$OMP end parallel
  RETURN
END SUBROUTINE Stackops

REAL*8 FUNCTION Func1 (x)

  REAL*8 x, q
  INTEGER n, i

  n = 2000
  q = 1000.0

  DO i=1,n
     q = q - x
  END DO
  if (q.eq.1.0d10) print *,q

  Func1 = x * x
  RETURN
END FUNCTION Func1

REAL*8 FUNCTION Func2(x)

  REAL*8 x, q
  INTEGER n, i

  n = 20000
  q = 1000.0

  DO i=1,n
     q = q - x
  END DO
  if (q.eq.1.0d10) print *,q

  Func2 = x * x
  RETURN
END FUNCTION Func2

REAL*8 FUNCTION Func3 (x)

  REAL*8 x, q
  INTEGER n, i

  n = 200000
  q = 1000.0

  DO i=1,n
     q = q - x
  END DO
  if (q.eq.1.0d10) print *,q

  Func3 = x * x
  RETURN
END FUNCTION Func3


C FILE: F_DIST.F
      SUBROUTINE f_dist(n1,n2,x1,y1,z1,x2,y2,z2,result)
C
C     CALCULATRE DISTANCES USING FORTRAN
C
      DIMENSION x1(*), y1(*), z1(*), x2(*), y2(*), z2(*), result(*)
      INTEGER n1,n2,k
      REAL x1,y1,z1,x2,y2,z2,result,dx,dy,dz
Cf2py intent(in, out, overwrite) result
C
      k = 0
      DO j = 1,n2
         DO i = 1,n1
            k = k + 1
            dx = x2(j) - x1(i)
            dy = y2(j) - y1(i)
            dz = z2(j) - z1(i)
            result(k) = dx*dx + dy*dy + dz*dz
         ENDDO
      ENDDO
      END
C END FILE F_DIST.F


module sym_cnst_odiag

  use precision, only: ip, sp, dp
  use test_vars, only: fmt_test_name, fmt_test_res

  use tridiag, only: tridiag_sym_cnst_odiag
  use tridiag_matmul, only: tridiag_matmul_sym_cnst_odiag

  implicit none
  private

  public :: sym_cnst_odiag_tests

  real(sp) :: dev_sp
  real(dp) :: dev_dp

contains

  subroutine sym_cnst_odiag_tests()

    write(*, fmt_test_name, advance="no") "sym_cnst_odiag"

    dev_dp = sym_cnst_odiag_real_dp()
    write(*, fmt_test_res, advance="no") dev_dp

    dev_sp = sym_cnst_odiag_real_sp()
    write(*, fmt_test_res, advance="no") dev_sp

    dev_dp = sym_cnst_odiag_cmplx_dp()
    write(*, fmt_test_res, advance="no") dev_dp

    dev_sp = sym_cnst_odiag_cmplx_sp()
    write(*, fmt_test_res, advance="no") dev_sp

    write(*,*)

  end subroutine sym_cnst_odiag_tests

  real(dp) function sym_cnst_odiag_real_dp() result(val)
    integer(ip), parameter :: fp = dp

    include "./sym_cnst_odiag_src/real.src"
  end function sym_cnst_odiag_real_dp

  real(dp) function sym_cnst_odiag_cmplx_dp() result(val)
    integer(ip), parameter :: fp = dp

    include "./sym_cnst_odiag_src/cmplx.src"
  end function sym_cnst_odiag_cmplx_dp

  real(sp) function sym_cnst_odiag_real_sp() result(val)
    integer(ip), parameter :: fp = sp

    include "./sym_cnst_odiag_src/real.src"
  end function sym_cnst_odiag_real_sp

  real(sp) function sym_cnst_odiag_cmplx_sp() result(val)
    integer(ip), parameter :: fp = sp

    include "./sym_cnst_odiag_src/cmplx.src"
  end function sym_cnst_odiag_cmplx_sp

end module sym_cnst_odiag


!---------------------------------------------------------------------------------
!Author: Matias Pablo, Borghi Orue
!Title: 2D Monte Carlo simulation of the Modified Ising Model
!Version: 3
!Comments:  $ gfortran ranmar_seed.f95 subroutines.f95 kawasaki.f95 -o runv1
!DynamicLattice: $./runv1 | ./dllinux.exe -1 -nx 20 -ny 20 -grid -z -1 1
!INPUTS: ConfigurationFile
!OUTPUTS: Three dat files: 'Magnetization30L.dat', 'Energy30L.dat' and 'Inter.dat'
!----------------------------------------------------------------------------------
program kawasaki

use subroutines
use rm
use iso_fortran_env
implicit none

	integer, parameter :: dp = selected_real_kind(15, 307) !For double precision
	integer::nrows,ncols,iniseed,npoints
	integer::average
	integer::posx,posy,newposx,newposy,dim
	real::npos,nneg,nnull !Sum of thes values = 1
	real::probpos,probneg,probnull !Probability of picking a positive spin
	real::extMagField
	integer(kind=int64):: MCS, EquilSteps,exchangeCounter = 0!, NumofTempPoints
	integer(kind=int64):: i,j!,indexTemp !Dummy indeces
	integer::k,printOPT,spinDyn,pointStart
	integer :: index1, index2
	integer::exchangeSpin
	integer,allocatable::matriz(:,:)
	integer,allocatable::ip(:),im(:)
	integer::promediateCounter
	integer::IDfile1,IDfile2,counter
	integer(kind=int64),allocatable::contador(:)
	real,allocatable::alpha(:,:)
	real::alpha11,alpha13,alpha33
	logical::cond
	!Type interaction v2:  4N values
	real(dp),allocatable::f1(:,:),f2(:,:),f3(:,:),f4(:,:)
	!integer::interPos,interNeg,interPN
	!real,allocatable::rIdeal(:),rMeasured(:),rho(:)
	!real::rIdeal,rMeasured,rho
	real::Delta_E,Delta_E2,Delta_E3
	real::rvec(1)
	real(dp),allocatable::Magnetization(:), Magnetization2(:),Magnetization4(:),Energy(:),Energy2(:),magnetANTI(:),magnetANTI2(:),magnetANTI4(:),magnetFerro(:),magnetFerro2(:),magnetFerro4(:)
	real(dp),dimension(20)::DeltaE
	real::currentTemp,beta
	character(len=100)::MagFile ='Magnetization20L.dat', EnergFile = 'Energy20L.dat'
	character(len=100)::InterFile='Inter20L.dat',spinStepsFile='spinSteps.dat'
	character(len=100):: folderName,FileOutput='OutputFile.log'
	logical::dir_e
	character(len=10):: stringL,stringMCS,stringAver,stringTemp,stringNpos,stringProbpos,stringAlpha

	! Read in input parameters from file "ising.in"
	open(unit=11,file="ConfigurationFile",status="old",action="read")
	read(11,*);read(11,*) printOPT
	read(11,*);read(11,*) spinDyn
	read(11,*);read(11,*) iniseed
	read(11,*);read(11,*) npos
	read(11,*);read(11,*) nneg
	read(11,*);read(11,*) probpos
	read(11,*);read(11,*) probneg
	read(11,*);read(11,*) nrows
	read(11,*);read(11,*) ncols
	read(11,*);read(11,*) MCS
	read(11,*);read(11,*) EquilSteps
	read(11,*);read(11,*) currentTemp
	read(11,*);read(11,*) pointStart
	read(11,*);read(11,*) npoints
	read(11,*);read(11,*) average
	read(11,*);read(11,*) alpha11
	read(11,*);read(11,*) alpha13
	read(11,*);read(11,*) alpha33
	read(11,*);read(11,*) extMagField
	close(11)

	! Allocate the space for some important quantities.
	allocate(matriz(nrows,ncols))
	allocate(alpha(3,3))

	allocate(Magnetization(npoints))
	allocate(Magnetization2(npoints))
	allocate(Magnetization4(npoints))
	allocate(Energy(npoints))
	allocate(Energy2(npoints))
	allocate(magnetANTI(npoints))
	allocate(magnetANTI2(npoints))
	allocate(magnetANTI4(npoints))
	allocate(magnetFerro(npoints))
	allocate(magnetFerro2(npoints))
	allocate(magnetFerro4(npoints))

	!Needs to be improved. Now it is made for square lattices
	allocate(im(nrows))
	allocate(ip(nrows))

	allocate(f1(2,npoints)) !Second index is fup.up f(2,:), First fdown.down f(1,:)
	allocate(f2(2,npoints))
	allocate(f3(2,npoints))
	allocate(f4(2,npoints))

	allocate(contador(npoints))
	contador(:) = 0
	!allocate(rIdeal(average))
	!allocate(rMeasured(average))
	!allocate(rho(average))

	!Fill ip & im arrays
	do i = 1,nrows
		ip(i) = i+1
		im(i) = i-1
	end do
	ip(nrows) = 1
	im(1) = nrows

	dim = nrows*ncols

	!Create the folder name
	!Cast integer/real to string
	write(stringL,'(I3.3)') nrows
	write(stringMCS,'(I8.8)') MCS
	write(stringAver,'(I2)') average
	write(stringAlpha,'(3F3.0)') alpha11,alpha13,alpha33
	write(stringTemp,'(F5.1)') currentTemp
	write(stringNpos,'(F3.1)') npos
	write(stringProbpos,'(F3.1)') probpos
	!Merge the strings
	!ie., name: L=20 alfa 111 t=0.9 n+=0.5 p+=0.5 aver=10 mcs=500mil
	folderName = 'L='//trim(stringL)//'/'//'Temp='//trim(stringTemp)
	!		'N+='//trim(stringNpos)//'P+='//trim(stringProbpos)//'/'//'MCS='//trim(stringMCS)//'Aver='//trim(stringAver)
	!Does the folder already exist?
	!inquire(FILE=trim(folderName)//'/.', EXIST=dir_e)

	!write(*,*) 'Does the folder ',trim(folderName),' exists?'
	!STOP 'Lo terminé'
	!if(dir_e) then
	open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),status="replace",action="write")
	write(2,*) 'Parameters in this simulation'
	write(2,*) 'L=',nrows
	write(2,*) 'Temp=',currentTemp
	write(2,*) 'Alpha=',alpha11,' ',alpha13,' ',alpha33
	write(2,*) 'N+=',npos
	write(2,*) 'p+=',probpos
	write(2,*) 'MCS=',MCS
	write(2,*) 'aver=',average
		!write(2,*) 'Directory already exists!'
	!else
		!call system('mkdir -p ' // trim(folderName) )
		!open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),status="replace",action="write")
		!write(2,*) 'Folder created!'
	!end if

	!Determine the number of holes and check for erros
	if ( (npos + nneg) > 1.0 ) then
		WRITE(2,*) 'ERROR! Wrong numbers for particle densities: npos + nneg should be <= 1.0.'
		call EXIT(0)
	else
		nnull = 1.0 -npos - nneg
	end if

	!Determine the 'picking frequency' for different particle types
	if ((probpos + probneg) > 1.0) then
		!STOP 'Wrong numbers for particle picking frequencies: probpos + probneg should be <= 1.0.'
		write(2,*) 'ERROR! Wrong numbers for particle picking frequencies: probpos + probneg should be <= 1.0.'
		call EXIT(0)
	else
		probnull = 1.0 - probpos - probnull
	end if

	!MCS = dim*10
	!EquilSteps = int (0.5*MCS)

	if ( EquilSteps >= MCS ) then
		write(2,*) 'Error! Change the value of EquilSteps in the Configuration File! It can not be greater than MCS'
		call EXIT(0)
	end if

	write(2,*) 'Semilla RANMAR: ',iniseed
	!1MCS = dim = nrows*ncols = 400
	! 10 000 MCS = 4M
	write(2,*) "MCS = ",MCS, " EquilSteps = ", EquilSteps!,"printOPT = ",printOPT

	!If the file exists overwrite erase it.
	!FileIDs
	IDfile1 = 34
	IDfile2 = 35
	open (UNIT=1, FILE=trim(folderName)//'/'//trim(MagFile),ACTION='write',STATUS='replace')
	write(1,*) "Tiempo",",","AverMagnetization",",","AverMagnetization^2",",","Suceptibility",",","Cumulant",",","magnetANTI",",","magnetANTI2",",","magnetANTI4",",","SusceptANTI",",","CumulantANTI",",","magnetFerro",",","magnetFerro2",",","magnetFerro4",",","SusceptFerro",",","CumulantFerro"
	open (UNIT=33, FILE=trim(folderName)//'/'//trim(EnergFile),ACTION='write',STATUS='replace')
	write(33,*) "Tiempo",",","  AverEnergy",",","  AverEnergy^2",",","  C_v"
	open (UNIT=IDfile2, FILE=trim(folderName)//'/'//trim(InterFile),ACTION='write',STATUS='replace')
	write(IDfile2,*) "Tiempo,indexTime,f1up,f1down,f2up,f2down,f3up,f3down,f4up,f4down"
	open (UNIT=IDfile1, FILE=trim(folderName)//'/'//trim(spinStepsFile),ACTION='write',STATUS='replace')

	call ini_alpha(alpha,alpha11,alpha13,alpha33)

	beta = 1.0/currentTemp
	write(2,*) "Current Temperature T = ", currentTemp,"beta = ",beta
	!print *, 'npoints: ',npoints
	!Initialize some variables to zero
	call SetToZeroVariables(Magnetization,Magnetization2, Magnetization4,Energy,Energy2,magnetANTI,magnetANTI2,magnetANTI4,magnetFerro,magnetFerro2,magnetFerro4,f1,f2,f3,f4,npoints)
	close(2) !Closing OutputFile.dat
	!Define the values of DeltaE knowing the Temperature
	!Only two possible values
	! 1) DeltaE(1) = exp(-4/Temp)
	! 2) DeltaE(2) = exp(-8/Temp)
	call Inicializacion_DeltaE(DeltaE,currentTemp)

	do k = 1 , average
		!Initialize the matrix
		!with spin-up initial values
		call ini_matriz(matriz,nrows,ncols,npos,nneg,iniseed,k)
		!call WriteSpinConf(matriz,nrows,ncols)
		!Write initial spin configurations in screen for DynamicLattice
		if(printOPT /= 0 .AND. printOPT /= 4) then
			call WriteSpinConf(matriz,nrows,ncols)
		end if
		!call CountPosNeg(matriz,nrows,ncols,npos,nneg,nnull)
		open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),access="append",action="write")
		write(2,*) "Average loop k = ", k,"/",average
		close(2)
		promediateCounter = 0
		counter = 0
		!Choose a random point (posx,posy) where we begin calculating
		if (spinDyn == 1) then
			!Spinflip it is not done with probpos or probneg because of the dissipation of the spins. At low temperature
			!npos or nneg -> 0 so it is not possible to select spins with the requiered probability.
			call elegir_sitio_SpinFlip(nrows,ncols,posx,posy,iniseed,matriz,k)
		else !spinDyn==2
			call elegir_sitio_Kawasaki(nrows,ncols,posx,posy,iniseed,probpos,probneg,matriz,k)
		end if

		!Sum over one MonteCarlo time //dim = 1MC
		!Sum over A MonteCarlo time: A*dim
		!In the next loop we flip a sping according to some conditions
		do i=1,MCS

			do j = 1, dim

				!Calculate DeltaE for a given point (posx,posy)
				if (spinDyn == 1) then !SpinFlip Dynamics
					call CalcDeltaEnergySpinFlip(nrows,ncols,posx,posy,matriz,alpha,Delta_E,ip,im,iniseed,extMagField)
					!print *,Delta_E,'for i=',i
					if (Delta_E <= 0) then
						matriz(posx,posy) = -matriz(posx,posy)

					else
						call ranmar(rvec,1,iniseed*average)
						if (Delta_E == int(Delta_E) .AND. Delta_E<=20) then
							if (rvec(1) < DeltaE(int(Delta_E))) then
									matriz(posx,posy) = -matriz(posx,posy)
							end if
						else
							if ( rvec(1) < exp(-Delta_E/currentTemp) ) then
								matriz(posx,posy) = -matriz(posx,posy)
							end if
						end if
					end if

				else !spinDyn == 2 SPIN EXCHANGE DYNAMICS
					!Calculate the position of the neighbour to exchange
					call ranmar(rvec,1,iniseed)
					!A number between 1 and 4
					rvec(1) = floor( 4 * rvec(1) ) + 1
					!print*,"rvec: ",rvec(1)
					if ( rvec(1) == 1) then
						newposx = ip(posx)
						newposy = posy
						!print*,"En uno"
					else if ( rvec(1) == 2 ) then
						newposx = im(posx)
						newposy = posy
						!print*,"En dos"
					else if( rvec(1) == 3) then
						!print*,"En tres"
						newposx = posx
						newposy = ip(posy)
					else
						!print *,"En cuatro"
						newposx = posx
						newposy = im(posy)
					end if
					!print *,'Spin elegido s= ',matriz(posx,posy),'en',posx,posy,'Nuevo s=',matriz(newposx,newposy),'en',newposx,newposy
					!Dont compute DeltaE for Kawasaki if both spins to flip have the same sign.
					if (matriz(posx,posy) /= matriz(newposx,newposy)) then
						!print *, "Delta E: ",Delta_E
						call CalcDeltaEnergyKawasaki(nrows,ncols,posx,posy,matriz,alpha,Delta_E,ip,im,iniseed,newposx,newposy,extMagField)
						! ..Flipping Spin..
						!If the new Energy spin-state is negative with flip the spin
						!If not it will depend on the probability exp(-DeltaE/Temp) > random point
						!print *,'DeltaE: ',Delta_E
						!if (abs(Delta_E) == 16.0) then
							!print *, 'Delta E:', Delta_E
							!print *, 'Old = ',posx,posy,'New = ',newposx,newposy
							!print *, matriz(posx,posy),matriz(ip(posx),posy),matriz(im(posx),posy),matriz(posx,ip(posy)),matriz(posx,im(posy))
							!print *, matriz(newposx,newposy),matriz(ip(newposx),newposy),matriz(im(newposx),newposy), &
							!	matriz(newposx,ip(newposy)),matriz(newposx,im(newposy))
							!if (j>30) then
							!	STOP 'stop'
							!end if
						!	call CalcEnergy(nrows,ncols,posx,posy,matriz,alpha,Delta_E,ip,im,extMagField)
						!	call CalcEnergy(nrows,ncols,newposx,newposy,matriz,alpha,Delta_E2,ip,im,extMagField)
						!	Delta_E = Delta_E + Delta_E2 + &
						!		matriz(posx,posy)*matriz(newposx,newposy)*alpha(matriz(posx,posy)+2,matriz(newposx,newposy)+2)
						!	print *,'Einicial:',Delta_E

						!	call NeighboursEnergy(nrows,ncols,posx,posy,matriz,alpha,Delta_E3,ip,im)
						!	Delta_E3 = (Delta_E3 - extMagField)*matriz(newposx,newposy)
						!	print *,Delta_E3,matriz(posx,posy),matriz(ip(posx),posy),matriz(im(posx),posy),matriz(posx,ip(posy)),matriz(posx,im(posy))
						!	call NeighboursEnergy(nrows,ncols,newposx,newposy,matriz,alpha,Delta_E2,ip,im)
						!	Delta_E2 = (Delta_E2 - extMagField)*matriz(posx,posy)
						!	print *,Delta_E2
						!	Delta_E2 = Delta_E2 + Delta_E3 + &
						!		matriz(posx,posy)*matriz(newposx,newposy)*alpha(matriz(posx,posy)+2,matriz(newposx,newposy)+2)
						!	print *,'Efinal:',Delta_E2
						!	STOP 'Encontre uno'
						!end if

						if (Delta_E <= 0) then
							call exchange(nrows,ncols,posx,posy,matriz,ip,newposx,newposy)
							!print*,"Fue menor a cero"
							exchangeCounter = exchangeCounter + 1
						else
							call ranmar(rvec,1,iniseed*average)
							if (Delta_E == int(Delta_E) .AND. Delta_E<=20) then
								if (rvec(1) < DeltaE(int(Delta_E))) then
									call exchange(nrows,ncols,posx,posy,matriz,ip,newposx,newposy)
									exchangeCounter = exchangeCounter + 1
								end if
							else
								if ( rvec(1) < exp(-Delta_E/currentTemp) ) then
									call exchange(nrows,ncols,posx,posy,matriz,ip,newposx,newposy)
									exchangeCounter = exchangeCounter + 1
								end if
							end if
						end if
					end if
				end if

				!Choose a new random point (posx,posy) where we begin calculating
				if (spinDyn == 1) then
					call elegir_sitio_SpinFlip(nrows,ncols,posx,posy,iniseed,matriz,k)
				else !spinDyn==2
					call elegir_sitio_Kawasaki(nrows,ncols,posx,posy,iniseed,probpos,probneg,matriz,k)
					!print *,'Spin elegido s= ',matriz(posx,posy)
				end if
				!----------------------------------------------------------------
			end do !End loop dim

			if (pointStart == 0) then
				if (mod(i,(MCS/npoints)) == 0) then
					cond = .TRUE.
				else
					cond = .FALSE.
				end if
			else !pointStart == 1
				if (i > EquilSteps .AND. mod(i,(MCS-EquilSteps)/npoints) == 0) then
					cond = .TRUE.
				else
					cond = .FALSE.
				end if
			end if

			!Calculate the Magnetization and Energy after equilibrium
			if ( cond ) then !mod(i,MCS/npoints) == 0

				!print *,'Enter at time: ',i,'for ',promediateCounter+1
				promediateCounter = promediateCounter + 1
				call CalculationsINequilibrium (nrows,ncols,matriz,alpha,Delta_E,ip,im,currentTemp,&
					Magnetization(promediateCounter),Magnetization2(promediateCounter),Magnetization4(promediateCounter),&
					Energy(promediateCounter),Energy2(promediateCounter),k,extMagField,magnetANTI(promediateCounter),magnetANTI2(promediateCounter),magnetANTI4(promediateCounter),&
					magnetFerro(promediateCounter),magnetFerro2(promediateCounter),magnetFerro4(promediateCounter) )

				call CellInteraction(matriz,nrows,ncols,ip,im,k,&
					f1(:,promediateCounter),f2(:,promediateCounter),f3(:,promediateCounter),f4(:,promediateCounter))

				!Store the time desired to measure. They are not equidistant, so we need to do this
				contador(promediateCounter) = i
				!call WriteSpinConf(matriz,nrows,ncols)
			end if

			!----------------------------------------------------------------
			!-----PRINT SITES IN DYNAMIC LATTICE ----------------------------
			if(printOPT == 2 .OR. (printOPT == 3 .AND. ( mod(i,(MCS)/10) == 0) ) ) then
				do index2=1,nrows
					do index1=1,ncols
						write(*,*) index1,index2,matriz(index1,index2)
					end do
				end do
			end if
			!printOPT == 4 saves the intermediate values in a file
			if ( (printOPT == 4 .OR. printOPT==5) .AND.  (mod(i,(MCS)/10) == 0)  ) then
				do index2 = 1,nrows
					do index1 = 1,ncols
						if(index2 == nrows .AND. index1 == ncols) then
							write(IDfile1,'(I2.1,/)',advance='no') matriz(index1,index2)
						else
							write(IDfile1,'(I2.1)',advance='no') matriz(index1,index2)
							write(IDfile1,'(A)',advance='no') ","
						end if
						if(printOPT==5) then
							write(*,*) index1,index2,matriz(index1,index2)
						end if
					end do
				end do
			end if
			if ( (printOPT == 0 .OR. printOPT == 4) .AND. (mod(i,(MCS)/10) == 0)) then
				open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),access='append',action='write')
					counter = counter + 1
					write(2,*) 'Step ',counter, '/ 10'
				close(2)
			end if

		end do !End loop of the MC steps

	end do ! End loop of averages

	open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),access='append',action='write')
		write(2,*) 'Accepted = ', exchangeCounter/real(MCS*dim*average)
	close(2)

	!Save in file the Interaction arrays
	!call prom1dReal2Int(InterPos,average,promInterPos)
	!call prom1dReal2Int(InterNeg,average,promInterNeg)
	!call prom1dReal2Int(InterPN,average,promInterPN)
	!call prom1dp(rIdeal,average,promIdealR)
	!call prom1dp(rMeasured,average,promMeasuredR)
	!call prom1dp(rho,average,promRho)

	!Write the results in a file
	call Write2File(beta, Magnetization,Magnetization2, &
					Magnetization4,Energy,Energy2,magnetANTI,magnetANTI2,magnetANTI4,magnetFerro,magnetFerro2,magnetFerro4,npoints,average)
	!Write the results of interactions v2 in a file
	call WriteInteractions(IDfile2,f1,f2,f3,f4,nrows,ncols,npoints,average,contador)

	!Write final spin configurations in screen for DynamicLattice
	if(printOPT /= 0 .AND. printOPT /= 4) then
		call WriteSpinConf(matriz,nrows,ncols)
	end if

	close(1)
	close(33)
	close(IDfile1)
	close(IDfile2)
end program kawasaki

V6 Out-Of & On Equilibrium/V6.5 AntiFerro/kawasaki.f95