program do_while_test
    implicit none
    REAL :: x

    x = 5.0
    do while (x > 0.0)
        print '(F5.2)', x
        x = x - 0.5
    end do

end program do_while_test


*DECK CGEEV
      SUBROUTINE CGEEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO)
C***BEGIN PROLOGUE  CGEEV
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a complex general matrix.
C***LIBRARY   SLATEC
C***CATEGORY  D4A4
C***TYPE      COMPLEX (SGEEV-S, CGEEV-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, GENERAL MATRIX
C***AUTHOR  Kahaner, D. K., (NBS)
C           Moler, C. B., (U. of New Mexico)
C           Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     Abstract
C      CGEEV computes the eigenvalues and, optionally,
C      the eigenvectors of a general complex matrix.
C
C     Call Sequence Parameters-
C       (The values of parameters marked with * (star) will be changed
C         by CGEEV.)
C
C        A*      COMPLEX(LDA,N)
C                complex nonsymmetric input matrix.
C
C        LDA     INTEGER
C                set by the user to
C                the leading dimension of the complex array A.
C
C        N       INTEGER
C                set by the user to
C                the order of the matrices A and V, and
C                the number of elements in E.
C
C        E*      COMPLEX(N)
C                on return from CGEEV E contains the eigenvalues of A.
C                See also INFO below.
C
C        V*      COMPLEX(LDV,N)
C                on return from CGEEV if the user has set JOB
C                = 0        V is not referenced.
C                = nonzero  the N eigenvectors of A are stored in the
C                first N columns of V.  See also INFO below.
C                (If the input matrix A is nearly degenerate, V
C                 will be badly conditioned, i.e. have nearly
C                 dependent columns.)
C
C        LDV     INTEGER
C                set by the user to
C                the leading dimension of the array V if JOB is also
C                set nonzero.  In that case N must be .LE. LDV.
C                If JOB is set to zero LDV is not referenced.
C
C        WORK*   REAL(3N)
C                temporary storage vector.  Contents changed by CGEEV.
C
C        JOB     INTEGER
C                set by the user to
C                = 0        eigenvalues only to be calculated by CGEEV.
C                           neither V nor LDV are referenced.
C                = nonzero  eigenvalues and vectors to be calculated.
C                           In this case A & V must be distinct arrays.
C                           Also,  if LDA > LDV,  CGEEV changes all the
C                           elements of A thru column N.  If LDA < LDV,
C                           CGEEV changes all the elements of V through
C                           column N.  If LDA = LDV only A(I,J) and V(I,
C                           J) for I,J = 1,...,N are changed by CGEEV.
C
C        INFO*   INTEGER
C                on return from CGEEV the value of INFO is
C                = 0  normal return, calculation successful.
C                = K  if the eigenvalue iteration fails to converge,
C                     eigenvalues K+1 through N are correct, but
C                     no eigenvectors were computed even if they were
C                     requested (JOB nonzero).
C
C      Error Messages
C           No. 1  recoverable  N is greater than LDA
C           No. 2  recoverable  N is less than one.
C           No. 3  recoverable  JOB is nonzero and N is greater than LDV
C           No. 4  warning      LDA > LDV,  elements of A other than the
C                               N by N input elements have been changed
C           No. 5  warning      LDA < LDV,  elements of V other than the
C                               N by N output elements have been changed
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CBABK2, CBAL, COMQR, COMQR2, CORTH, SCOPY, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800808  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  CGEEV
      INTEGER I,IHI,ILO,INFO,J,K,L,LDA,LDV,MDIM,N
      REAL A(*),E(*),WORK(*),V(*)
C***FIRST EXECUTABLE STATEMENT  CGEEV
      IF (N .GT. LDA) CALL XERMSG ('SLATEC', 'CGEEV', 'N .GT. LDA.', 1,
     +   1)
      IF(N .GT. LDA) RETURN
      IF (N .LT. 1) CALL XERMSG ('SLATEC', 'CGEEV', 'N .LT. 1', 2, 1)
      IF(N .LT. 1) RETURN
      IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35
      MDIM = 2 * LDA
      IF(JOB .EQ. 0) GO TO 5
      IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'CGEEV',
     +   'JOB .NE. 0 AND N .GT. LDV.', 3, 1)
      IF(N .GT. LDV) RETURN
      IF(N .EQ. 1) GO TO 35
C
C       REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0
C
      MDIM = MIN(MDIM,2 * LDV)
      IF (LDA .LT. LDV) CALL XERMSG ('SLATEC', 'CGEEV',
     +   'LDA.LT.LDV,  ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' //
     +   'ELEMENTS HAVE BEEN CHANGED.', 5, 0)
      IF(LDA.LE.LDV) GO TO 5
      CALL XERMSG ('SLATEC', 'CGEEV',
     +   'LDA.GT.LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' //
     +   'ELEMENTS HAVE BEEN CHANGED.', 4, 0)
      L = N - 1
      DO 4 J=1,L
          I = 2 * N
         M = 1+J*2*LDV
         K = 1+J*2*LDA
         CALL SCOPY(I,A(K),1,A(M),1)
    4 CONTINUE
    5 CONTINUE
C
C     SEPARATE REAL AND IMAGINARY PARTS
C
      DO 6 J = 1, N
       K = (J-1) * MDIM +1
       L = K + N
       CALL SCOPY(N,A(K+1),2,WORK(1),1)
       CALL SCOPY(N,A(K),2,A(K),1)
       CALL SCOPY(N,WORK(1),1,A(L),1)
    6 CONTINUE
C
C     SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG.
C
      CALL CBAL(MDIM,N,A(1),A(N+1),ILO,IHI,WORK(1))
      CALL CORTH(MDIM,N,ILO,IHI,A(1),A(N+1),WORK(N+1),WORK(2*N+1))
      IF(JOB .NE. 0) GO TO 10
C
C     EIGENVALUES ONLY
C
      CALL COMQR(MDIM,N,ILO,IHI,A(1),A(N+1),E(1),E(N+1),INFO)
      GO TO 30
C
C     EIGENVALUES AND EIGENVECTORS.
C
   10 CALL COMQR2(MDIM,N,ILO,IHI,WORK(N+1),WORK(2*N+1),A(1),A(N+1),
     1  E(1),E(N+1),V(1),V(N+1),INFO)
      IF (INFO .NE. 0) GO TO 30
      CALL CBABK2(MDIM,N,ILO,IHI,WORK(1),N,V(1),V(N+1))
C
C     CONVERT EIGENVECTORS TO COMPLEX STORAGE.
C
      DO 20 J = 1,N
       K = (J-1) * MDIM + 1
       I = (J-1) * 2 * LDV + 1
       L = K + N
       CALL SCOPY(N,V(K),1,WORK(1),1)
       CALL SCOPY(N,V(L),1,V(I+1),2)
       CALL SCOPY(N,WORK(1),1,V(I),2)
   20 CONTINUE
C
C     CONVERT EIGENVALUES TO COMPLEX STORAGE.
C
   30 CALL SCOPY(N,E(1),1,WORK(1),1)
      CALL SCOPY(N,E(N+1),1,E(2),2)
      CALL SCOPY(N,WORK(1),1,E(1),2)
      RETURN
C
C     TAKE CARE OF N=1 CASE
C
   35 E(1) = A(1)
      E(2) = A(2)
      INFO = 0
      IF(JOB .EQ. 0) RETURN
      V(1) = A(1)
      V(2) = A(2)
      RETURN
      END


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    real*8, parameter  :: mu_w = 1d0
    real*8, parameter  :: sig_w = 0.0d0
    integer, parameter :: n_w = 5
    real*8, parameter  :: pen = mu_w

    real*8, parameter  :: R = 1d0
    real*8, parameter  :: beta = 1d0
    real*8, parameter  :: gamma = 0.5d0
    real*8, parameter  :: egam = 1d0 - 1d0/gamma
    real*8, parameter  :: a_lower = 0d0

    real*8, parameter  :: psi(2:3) = (/0.8d0, 0.5d0/)

    real*8 :: w(n_w), weight_w(n_w), p_a(2)
    real*8 :: a(3,n_w), omega(2,n_w), c(3,n_w)
    real*8 :: wag(3,n_w), inc(3,n_w), sav(3,n_w), alp(3,n_w)

contains

    ! utility function of the household
    function utility(x)

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: utility
        integer :: iw, ic

        ! savings
        a(1, :) = 0d0
        a(2, :) = x(1)
        omega(1, :) = x(2)
        ic = 3
        do iw = 1, n_w
            a(3, iw) = x(ic)
            omega(2, iw) = x(ic+1)
            ic = ic+2
        enddo

        ! consumption (insure consumption > 0)
        c(1,:) = mu_w - a(2,1)
        c(2,:) = R*(1d0-omega(1,1))*a(2,1) + omega(1,1)*a(2,1)/p_a(1) + &
                 w(:) - a(3,:)
        c(3,:) = R*(1d0-omega(2,:))*a(3,:) + omega(2,:)*a(3,:)/p_a(2)+ &
                 omega(1,1)*a(2,1)/p_a(1)+pen
        c = max(c, 1d-10)

        ! expected utility of periods 2 and 3
        utility = 0d0
        do iw = 1, n_w
            utility = utility+weight_w(iw)*(c(2,iw)**egam+psi(3)*beta*c(3,iw)**egam)
        enddo

        ! add first period utility
        utility = -(c(1,1)**egam + psi(2)*beta*utility)/egam

    end function

    ! calculates the expected value of x
    function E(x)

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: E
        integer :: iw

        ! calculate expected value
        E = 0d0
        do iw = 1, n_w
            E = e + x(iw)*weight_w(iw)
        enddo

    end function

    ! calculates the standard deviation of x
    function Std(x)

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: Std
        real*8 :: E
        integer :: iw

        ! calculate expected value
        E = 0d0
        do iw = 1, n_w
            E = E + x(iw)*weight_w(iw)
        enddo

        ! calculate standard deviation
        Std = 0d0
        do iw = 1, n_w
            Std = Std + x(iw)**2*weight_w(iw)
        enddo
        Std = sqrt(max(Std-E**2, 0d0))

    end function

end module


use IOClass
use ArrayClass
use FEMDomainClass
implicit none

type(IO_) :: f
type(FEMDomain_) :: domain

! allocatable array
real(real64),allocatable :: a(:), c(:)
integer(int32),allocatable :: c_int(:)
real(real64),allocatable :: c_matrix(:,:)

call domain%create("Sphere3D")
call domain%vtk("Shpere")

! dump JSON
a = linspace([0.0d0, 10.0d0],10)
call f%open("test.json","w")
call f%dump("sample_vector",a)
call f%dump("axis",[1,2,3])
call f%dump("Number_of_mesh",1)
call f%dump("Mesh_version",1.0)

! export character
call f%dump("Mesh_shape","Sphere")

! export nodes of mesh
call f%dump("cube_position_x",domain%x() )
call f%dump("cube_position_y",domain%y() )
call f%dump("cube_position_z",domain%z() )
call f%close()

! parse Vector from JSON
c = f%parse("test.json",key1="sample_vector")
call print(c)

! parse Vector from JSON
c_int = f%parse("test.json",key1="axis")
call print(c_int)

! bind vectors into a matrix
c_matrix = matrix(domain%x(),domain%y(),domain%z())

end


      SUBROUTINE LSI(E,F,G,H,LE,ME,LG,MG,N,X,XNORM,W,JW,MODE)

C     FOR MODE=1, THE SUBROUTINE RETURNS THE SOLUTION X OF
C     INEQUALITY CONSTRAINED LINEAR LEAST SQUARES PROBLEM:

C                    MIN ||E*X-F||
C                     X

C                    S.T.  G*X >= H

C     THE ALGORITHM IS BASED ON QR DECOMPOSITION AS DESCRIBED IN
C     CHAPTER 23.5 OF LAWSON & HANSON: SOLVING LEAST SQUARES PROBLEMS

C     THE FOLLOWING DIMENSIONS OF THE ARRAYS DEFINING THE PROBLEM
C     ARE NECESSARY
C     DIM(E) :   FORMAL (LE,N),    ACTUAL (ME,N)
C     DIM(F) :   FORMAL (LE  ),    ACTUAL (ME  )
C     DIM(G) :   FORMAL (LG,N),    ACTUAL (MG,N)
C     DIM(H) :   FORMAL (LG  ),    ACTUAL (MG  )
C     DIM(X) :   N
C     DIM(W) :   (N+1)*(MG+2) + 2*MG
C     DIM(JW):   LG
C     ON ENTRY, THE USER HAS TO PROVIDE THE ARRAYS E, F, G, AND H.
C     ON RETURN, ALL ARRAYS WILL BE CHANGED BY THE SUBROUTINE.
C     X     STORES THE SOLUTION VECTOR
C     XNORM STORES THE RESIDUUM OF THE SOLUTION IN EUCLIDIAN NORM
C     W     STORES THE VECTOR OF LAGRANGE MULTIPLIERS IN ITS FIRST
C           MG ELEMENTS
C     MODE  IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING MEANINGS:
C          MODE=1: SUCCESSFUL COMPUTATION
C               2: ERROR RETURN BECAUSE OF WRONG DIMENSIONS (N<1)
C               3: ITERATION COUNT EXCEEDED BY NNLS
C               4: INEQUALITY CONSTRAINTS INCOMPATIBLE
C               5: MATRIX E IS NOT OF FULL RANK

C     03.01.1980, DIETER KRAFT: CODED
C     20.03.1987, DIETER KRAFT: REVISED TO FORTRAN 77

      INTEGER          I,J,LE,LG,ME,MG,MODE,N,JW(LG)
      DOUBLE PRECISION E(LE,N),F(LE),G(LG,N),H(LG),X(N),W(*),
     .                 DDOT,XNORM,DNRM2,EPMACH,T,ONE
      DATA             EPMACH/2.22D-16/,ONE/1.0D+00/

C  QR-FACTORS OF E AND APPLICATION TO F

      DO 10 I=1,N
      J=MIN(I+1,N)
      CALL H12(1,I,I+1,ME,E(1,I),1,T,E(1,J),1,LE,N-I)
   10 CALL H12(2,I,I+1,ME,E(1,I),1,T,F     ,1,1 ,1  )

C  TRANSFORM G AND H TO GET LEAST DISTANCE PROBLEM

      MODE=5
      DO 30 I=1,MG
          DO 20 J=1,N
              IF (ABS(E(J,J)).LT.EPMACH) GOTO 50
   20         G(I,J)=(G(I,J)-DDOT(J-1,G(I,1),LG,E(1,J),1))/E(J,J)
   30     H(I)=H(I)-DDOT(N,G(I,1),LG,F,1)

C  SOLVE LEAST DISTANCE PROBLEM

      CALL LDP(G,LG,MG,N,H,X,XNORM,W,JW,MODE)
      IF (MODE.NE.1)                     GOTO 50

C  SOLUTION OF ORIGINAL PROBLEM

      CALL DAXPY(N,ONE,F,1,X,1)
      DO 40 I=N,1,-1
          J=MIN(I+1,N)
   40     X(I)=(X(I)-DDOT(N-I,E(I,J),LE,X(J),1))/E(I,I)
      J=MIN(N+1,ME)
      T=DNRM2(ME-N,F(J),1)
      XNORM=SQRT(XNORM*XNORM+T*T)

C  END OF SUBROUTINE LSI

   50 END


      SUBROUTINE difeq(k,k1,k2,jsf,is1,isf,indexv,ne,s,nsi,nsj,y,nyj,
     *nyk)
      INTEGER is1,isf,jsf,k,k1,k2,ne,nsi,nsj,nyj,nyk,indexv(nyj),M
      REAL s(nsi,nsj),y(nyj,nyk)
      COMMON /sfrcom/ x,h,mm,n,c2,anorm
      PARAMETER (M=41)
      INTEGER mm,n
      REAL anorm,c2,h,temp,temp2,x(M)
      if(k.eq.k1) then
        if(mod(n+mm,2).eq.1)then
          s(3,3+indexv(1))=1.
          s(3,3+indexv(2))=0.
          s(3,3+indexv(3))=0.
          s(3,jsf)=y(1,1)
        else
          s(3,3+indexv(1))=0.
          s(3,3+indexv(2))=1.
          s(3,3+indexv(3))=0.
          s(3,jsf)=y(2,1)
        endif
      else if(k.gt.k2) then
        s(1,3+indexv(1))=-(y(3,M)-c2)/(2.*(mm+1.))
        s(1,3+indexv(2))=1.
        s(1,3+indexv(3))=-y(1,M)/(2.*(mm+1.))
        s(1,jsf)=y(2,M)-(y(3,M)-c2)*y(1,M)/(2.*(mm+1.))
        s(2,3+indexv(1))=1.
        s(2,3+indexv(2))=0.
        s(2,3+indexv(3))=0.
        s(2,jsf)=y(1,M)-anorm
      else
        s(1,indexv(1))=-1.
        s(1,indexv(2))=-.5*h
        s(1,indexv(3))=0.
        s(1,3+indexv(1))=1.
        s(1,3+indexv(2))=-.5*h
        s(1,3+indexv(3))=0.
        temp=h/(1.-(x(k)+x(k-1))**2*.25)
        temp2=.5*(y(3,k)+y(3,k-1))-c2*.25*(x(k)+x(k-1))**2
        s(2,indexv(1))=temp*temp2*.5
        s(2,indexv(2))=-1.-.5*temp*(mm+1.)*(x(k)+x(k-1))
        s(2,indexv(3))=.25*temp*(y(1,k)+y(1,k-1))
        s(2,3+indexv(1))=s(2,indexv(1))
        s(2,3+indexv(2))=2.+s(2,indexv(2))
        s(2,3+indexv(3))=s(2,indexv(3))
        s(3,indexv(1))=0.
        s(3,indexv(2))=0.
        s(3,indexv(3))=-1.
        s(3,3+indexv(1))=0.
        s(3,3+indexv(2))=0.
        s(3,3+indexv(3))=1.
        s(1,jsf)=y(1,k)-y(1,k-1)-.5*h*(y(2,k)+y(2,k-1))
        s(2,jsf)=y(2,k)-y(2,k-1)-temp*((x(k)+x(k-1))*.5*(mm+1.)*(y(2,k)+
     *y(2,k-1))-temp2*.5*(y(1,k)+y(1,k-1)))
        s(3,jsf)=y(3,k)-y(3,k-1)
      endif
      return
      END

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


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine preparation_RT_collision
  use global_variables
  implicit none
  integer :: ix,iy
  real(dp) :: k_mom, tmp
  complex(zp) :: ztmp1,ztmp2
  complex(zp) :: zwfn_prj(0:Nx)

  k_mom = sqrt(2d0*Ekin0)
  write(*,*)'k_mom =',k_mom

  allocate(zwfn(0:Nx,0:Nx),  zwfn_Lanczos(0:Nx,0:Nx,NLanczos))
  allocate(field_t(0:Nt_iter+1))
  allocate(dipole_t(0:Nt_iter),norm_t(0:Nt_iter))

  do ix = 0,Nx
    zwfn_prj(ix) = exp(zI*k_mom*xn(ix))*exp(-0.5d0*((xn(ix)-x0_col)/delta_x_col)**2)
  end do
  ztmp1 = sum(zwfn_prj(:)*wfn_sp(:))*dx
  zwfn_prj = zwfn_prj - ztmp1 * wfn_sp

  tmp = sum(abs(zwfn_prj(:))**2)*dx
  zwfn_prj = zwfn_prj /sqrt(tmp)

  do ix = 0,Nx
  do iy = 0,Nx
    ztmp1 = zwfn_prj(ix)*wfn_sp(iy)
    ztmp2 = zwfn_prj(iy)*wfn_sp(ix)
!    ztmp1 = exp(zI*k_mom*xn(ix))*exp(-0.5d0*((xn(ix)-x0_col)/delta_x_col)**2)*wfn_sp(iy)
!    ztmp2 = exp(zI*k_mom*xn(iy))*exp(-0.5d0*((xn(iy)-x0_col)/delta_x_col)**2)*wfn_sp(ix)
    zwfn(ix,iy) = ztmp1 + ztmp2
  end do
  end do

! Normalize
  tmp = sum(abs(zwfn(:,:))**2)*dx**2
  zwfn(:,:) = zwfn(:,:)/sqrt(tmp)

  call zwfn_rho
  call zwfn_jx

  open(21,file='initial_rho.out')
  do ix = 0,Nx
    write(21,'(999e26.16e3)')xn(ix),rho(ix),jx(ix)
  end do
  close(21)

  return
end subroutine preparation_RT_collision


PROGRAM flatlens

  use random
  USE healpix_types
  USE fitstools, only: fits2cl
  use alm_tools, only: create_alm
  use rngmod, only: rand_init, planck_rng
  use AMLutils, only: spline_double
  USE sub_flatlens

  implicit none

  include "fftw3.f"

!!!!========================================================!!!!!!!
!! ALLOCATE
!!!!========================================================!!!!!!!
  type(planck_rng) :: rng_handle

  character(len=128)  :: clfile
  integer(I4b):: lmax,ncl,ios
  integer(I8b)::i
  real(dp), dimension(:,:), allocatable :: ps1d,check,cl
  real(dp), dimension(:), allocatable:: CTT2,ell
  complex, dimension(:,:,:), allocatable :: almloaded
  character(len=80), dimension(1:70) :: header,units
  logical :: RandInited = .false.
  real(dp) ::cl3,tempCl,t1,t2

  INTEGER OMP_GET_MAX_THREADS
  INTEGER OMP_GET_NUM_THREADS
  INTEGER OMP_GET_THREAD_NUM

!!!!========================================================!!!!!!!
!! FFTW3 PARAMETERS
!!!!========================================================!!!!!!!
  integer(I8b)::plan_backward,plan_forward
  complex(kind=DPC), dimension(:,:), allocatable :: in,out

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

  !! grid parameters
!!! NOTE WE ARE STARTING FROM (0,0) indeces yu can always do that in FORTRAN
!!! initializing the array as below

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

  complex(kind=DPC), dimension(:,:,:),allocatable::GRIDHARMTPHI
  complex(kind=DPC), dimension(:,:,:),allocatable::GRIDTPHI
  integer(I4b),parameter::imax=2**10,jmax=2**10
  real(dp)::delx,dely
  real(dp)::tamp,phiamp, x,y,lenght,l
  integer(i4b)::icounter,jcounter,icenter,jcenter
  allocate(GRIDHARMTPHI(0:(imax-1),0:(jmax-1),1:2))
  allocate(GRIDTPHI(0:(imax-1),0:(jmax-1),1:2))
  allocate(check(0:(imax-1),0:(jmax-1)))
  check(:,:)=0
  !write(*,*) size(GRIDHARMTPHI)

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

!! set sizes load CL and allocate all the stuff we need
!!!!========================================================!!!!!!!

  !character(len=80):: units
  ncl=2
  lmax=3000

  !! find a clever way to automatically set the uvcell dimension
  !! to get a good sample between l=0 and l<lmax
  delx=max(1 , floor((SQRT2*lmax/imax)-1))
  dely=delx

  write(*,*) 'delx ',delx
  !!!!========================================================!!!!!!!

  allocate(cl(0:lmax,1:ncl))
  allocate(ps1d(0:lmax,1:1))
  allocate(almloaded(1:1,0:lmax,0:128))
!!!!========================================================!!!!!!!

  clfile='test_scal2Cls.dat'
  cl=0
  call read_camb(clfile, cl, lmax)

  !call fits2cl(clfile,cl,lmax,ncl,header,units)
  !! slpine Cls to fill non integer k (same as l ) on the 2d grid

  allocate(CTT2(0:lmax))
  allocate(ell(0:lmax))

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

!! this is only to get a double version of l in Cl maybee not needed

  DO i=0,lmax
     ell(i)=i
  END DO
 ! Write(*,*) cl(120,1)
  call spline_double(ell,cl(0:lmax,1),lmax+1,cTT2(0:lmax))
!!!!========================================================!!!!!!!

  !!!!========================================================!!!!!!!
  ! check spline
  !!!!========================================================!!!!!!!

! do l = 1, 1000, 1

! write(*,*) cl(l,1),tempCl
! !write(unit=iounit, fmt="(format string)", iostat=ios, advance='NO') cl(l,1),tempCl
! !if ( ios /= 0 ) stop "Write error in file unit iounit"

! end do
!!!!========================================================!!!!!!!

!!! now create lx ly coefficient in 2d Flat sky approximation
  !! Prepere for gaussian generation

  call InitRandom
  RandInited = .true.
  !Write(*,*) gaussian1()
!! then you can use Gaussian(1) to extract

!!!!========================================================!!!!!!!
!! grid
!!!!========================================================!!!!!!!

!!look notes---> thanks to simmetry we can loop on only the half of the grid.

!GOTO 100

icenter=0
jcenter=0
!write(*,*) jmax/2+1,imax/2+1

!!!!========================================================!!!!!!!
!!!! FILL THE GRID WITH CL OF TT IN THIS CASE
!!!! TODO GENERALIZE FOR PHI
!!!!========================================================!!!!!!!

  GRIDHARMTPHI(0,0,:)=0

  DO icounter=1,imax/2-1
    jcounter=0
    lenght=sqrt(((icounter-imax/2)*delx)**2+((jcounter-jmax/2)*dely)**2)
    call splint(dble(ell),cl(0:lmax,1),cTT2(0:lmax),lmax+1,lenght,tempCl)
    tamp = sqrt(tempCl/2d0)
    phiamp=sqrt(cl(int(lenght),2)/2)
    !write(*,*) icounter,jcounter,imax-icounter

    GRIDHARMTPHI(icounter,jcounter,1)= cmplx(Gaussian1(),Gaussian1())*tamp
    GRIDHARMTPHI(imax-icounter,jcounter,1)=  CONJG(GRIDHARMTPHI(icounter,jcounter,1))
    GRIDHARMTPHI(icounter,jcounter,2)= cmplx(Gaussian1(),Gaussian1())*phiamp
    GRIDHARMTPHI(imax-icounter,jcounter,2)=  CONJG(GRIDHARMTPHI(icounter,jcounter,2))
   ! check(icounter,jcounter)=1
  !  check(imax-icounter,jcounter)=1
 enddo

 do jcounter=1,jmax/2-1
  icounter=0
  lenght=sqrt(((icounter-imax/2)*delx)**2+((jcounter-jmax/2)*dely)**2)
  call splint(dble(ell),cl(0:lmax,1),cTT2(0:lmax),lmax+1,lenght,tempCl)
  tamp = sqrt(tempCl/2d0)
  phiamp=sqrt(cl(int(lenght),2)/2)

  GRIDHARMTPHI(icounter,jcounter,1)= cmplx(Gaussian1(),Gaussian1())*tamp
    GRIDHARMTPHI(icounter,jmax-jcounter,1)= CONJG(GRIDHARMTPHI(icounter,jcounter,1))
    GRIDHARMTPHI(icounter,jcounter,2)= cmplx(Gaussian1(),Gaussian1())*phiamp
    GRIDHARMTPHI(imax-icounter,jcounter,2)=  CONJG(GRIDHARMTPHI(icounter,jcounter,2))

   !  check(icounter,jcounter)=1

  !  check(icounter,jmax-jcounter)=1
 end do

!OMP PARALLEL DO PRIVATE(icounter,jcounter)
    write(*,*) 'here',imax/2-1

do icounter=1,imax/2-1
  do jcounter=1,jmax-1

      lenght=sqrt(((icounter-imax/2)*delx)**2+((jcounter-jmax/2)*dely)**2)
      call splint(dble(ell),cl(0:lmax,1),cTT2(0:lmax),lmax+1,lenght,tempCl)
      tamp = sqrt(tempCl/2d0)
      phiamp=sqrt(cl(int(lenght),2)/2)

    !write(*,*) icounter,jcounter,imax-icounter,jmax-jcounter

    GRIDHARMTPHI(icounter,jcounter,1)= cmplx(Gaussian1(),Gaussian1())*tamp
    GRIDHARMTPHI(imax-icounter,jmax-jcounter,1)= Conjg(GRIDHARMTPHI(icounter,jcounter,1))
    GRIDHARMTPHI(icounter,jcounter,2)= cmplx(Gaussian1(),Gaussian1())*phiamp
    GRIDHARMTPHI(imax-icounter,jcounter,2)=  CONJG(GRIDHARMTPHI(icounter,jcounter,2))
    !         check(icounter,jcounter)=1
   ! check(imax-icounter,jmax-jcounter)=1

  end do
!OMP END PARALLEL DO NOWAIT

end do

do jcounter=1,jmax/2-1
  icounter=imax/2

  lenght=sqrt(((icounter-icenter)*delx)**2+((jcounter-jcenter)*dely)**2)
  call splint(dble(ell),cl(0:lmax,1),cTT2(0:lmax),lmax+1,lenght,tempCl)
  tamp = sqrt(tempCl/2d0)
  phiamp=sqrt(cl(int(lenght),2)/2)

  GRIDHARMTPHI(icounter,jcounter,1)= cmplx(Gaussian1(),Gaussian1())*tamp
  GRIDHARMTPHI(imax-icounter,jmax-jcounter,1)= conjg(GRIDHARMTPHI(icounter,jcounter,1))
  GRIDHARMTPHI(icounter,jcounter,2)= cmplx(Gaussian1(),Gaussian1())*phiamp
  GRIDHARMTPHI(imax-icounter,jcounter,2)=  CONJG(GRIDHARMTPHI(icounter,jcounter,2))
   !check(icounter,jcounter)=1
   ! check(imax-icounter,jmax-jcounter)=1
   end do

 icounter=imax/2
 jcounter=0
  lenght=sqrt(((icounter-icenter)*delx)**2+((jcounter-jcenter)*dely)**2)
call splint(dble(ell),cl(0:lmax,1),cTT2(0:lmax),lmax+1,lenght,tempCl)
  tamp = sqrt(tempCl)
  phiamp=sqrt(cl(int(lenght),2))

  GRIDHARMTPHI(icounter,jcounter,1)= cmplx(Gaussian1(),0)*tamp
  GRIDHARMTPHI(jcounter,icounter,1)= cmplx(Gaussian1(),0)*tamp
  GRIDHARMTPHI(icounter,jcounter,1)= cmplx(Gaussian1(),0)*phiamp
  GRIDHARMTPHI(jcounter,icounter,1)= cmplx(Gaussian1(),0)*phiamp

    ! check(icounter,jcounter)=1
   ! check(jcounter,icounter)=1

  jcounter=jmax/2
  call splint(dble(ell),cl(0:lmax,1),cTT2(0:lmax),lmax+1,lenght,tempCl)
  tamp = sqrt(tempCl)
  phiamp=sqrt(cl(int(lenght),2))

  GRIDHARMTPHI(icounter,jcounter,1)= cmplx(Gaussian1(),0)*tamp
  GRIDHARMTPHI(icounter,jcounter,1)= cmplx(Gaussian1(),0)*phiamp

    !check(icounter,jcounter)=1

!Write(*,*) GRIDHARMTPHI(0,:,1),'\'
!Write(*,*) GRIDHARMTPHI(1,:,1)
!Write(*,*) GRIDHARMTPHI(2,:,1)
!Write(*,*) GRIDHARMTPHI(3,:,1)
!Write(*,*) GRIDHARMTPHI(4,:,1)
!Write(*,*) GRIDHARMTPHI(5,:,1)
!Write(*,*) GRIDHARMTPHI(6,:,1)
!Write(*,*) GRIDHARMTPHI(7,:,1)

!!!!========================================================!!!!!!!
!!!! CHECK IF I FILL THE GRID CORRECTLY
!!!!========================================================!!!!!!!

write(*,*) GRIDHARMTPHI(0,0,1)
call ps_azim(imax,jmax,GRIDHARMTPHI(:,:,2),icenter,jcenter,lmax,delx,ps1d)

open(unit=10, file='sanitycheckCl.dat', iostat=ios, status="REPLACE", action="write")
if ( ios /= 0 ) stop "Error opening file name"

do l = 1, lmax, 1
!write(*,"(E14.7)") ps1d(l,1)
write(10,'(I5.2,E14.7)') int(l), ps1d(l,1)

end do

close(unit=10, iostat=ios)
if ( ios /= 0 ) stop "Error closing file unit 10"

!!!!========================================!!!
  ! INITIALIZE THE FOURIER PLAN
!!!!========================================!!!

200 call dfftw_plan_dft_2d_ ( plan_backward, imax, jmax, GRIDHARMTPHI(:,:,2), GRIDTPHI(:,:,2), FFTW_BACKWARD, &
    FFTW_ESTIMATE )

  call dfftw_execute_ (plan_backward)

!Write(*,*) GRIDHARMTPHI(0,:,1)
!Write(*,*) GRIDHARMTPHI(1,:,1)
!Write(*,*) GRIDHARMTPHI(2,:,1)
!Write(*,*) GRIDHARMTPHI(3,:,1)
!write(*,*) '\n'

!Write(*,*) GRIDTPHI(0,:,1)
!Write(*,*) GRIDTPHI(1,:,1)
!Write(*,*) GRIDTPHI(2,:,1)
!Write(*,*) GRIDTPHI(3,:,1)

  call dfftw_plan_dft_2d_ ( plan_forward,imax, jmax, GRIDTPHI(:,:,2), GRIDHARMTPHI(:,:,2), FFTW_FORWARD, &
    FFTW_ESTIMATE)

  call dfftw_execute_ ( plan_forward )

  call ps_azim(imax,jmax,GRIDHARMTPHI(:,:,2),icenter,jcenter,lmax,delx,ps1d)

open(unit=10, file='sanitycheck2Cl.dat', iostat=ios, status="REPLACE", action="write")
if ( ios /= 0 ) stop "Error opening file name"

do l = 1, lmax, 1
!write(*,"(E14.7)") ps1d(l,1)
write(10,'(I5.2,E14.7)') int(l), ps1d(l,1)/(real(imax*jmax,DP)**2)

end do

close(unit=10, iostat=ios)
if ( ios /= 0 ) stop "Error closing file unit 10"

  write(*,*)  shape(GRIDHARMTPHI(:,:,1)),shape(GRIDTPHI(:,:,1))!,GRIDTPHI(:,:,1)

  call dfftw_destroy_plan_ ( plan_forward )
  call dfftw_destroy_plan_ ( plan_backward )

stop

 !-----------------------------------------------------------------------
  !                       end of routine
  !-----------------------------------------------------------------------

  WRITE(*,9000) " "
  WRITE(*,9000) " flatlens > normal completion"

9000 format(a)

CONTAINS

   SUBROUTINE splint(xa, ya, y2a, n, x, y)
!   USE nrtype
!
! Given the arrays xa(1:n) and ya(1:n) of length n, which tabulate a function
! (with the xa(i) in order), and given the array y2a(1:n), which is the output
! from the subroutine spline, and given a value of x, this routine returns a
! cubic spline interpolated value y.
! (adopted from Numerical Recipes in FORTRAN 77)
!
   INTEGER, PARAMETER :: DP = KIND(1.0D0)
   INTEGER:: n
   REAL(DP):: x, y, xa(n), y2a(n), ya(n)
   INTEGER:: k, khi, klo
   REAL(DP):: a, b, h

     klo=1
     khi=n
1   if (khi-klo.gt.1) then
        k=(khi+klo)/2
        if (xa(k).gt.x) then
           khi=k
        else
           klo=k
        endif
        goto 1
     endif

     h=xa(khi)-xa(klo)
     if (h.eq.0.) pause 'bad xa input in splint'

     a=(xa(khi)-x)/h
     b=(x-xa(klo))/h
     y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.

     return

   END SUBROUTINE splint

END PROGRAM flatlens


      subroutine dicfs(n,nnz,a,adiag,acol_ptr,arow_ind,
     +                 l,ldiag,lcol_ptr,lrow_ind,
     +                 p,alpha,iwa,wa1,wa2)
      integer n, nnz, p
      integer acol_ptr(n+1), arow_ind(nnz)
      integer lcol_ptr(n+1), lrow_ind(nnz+n*p)
      integer iwa(3*n)
      double precision alpha
      double precision wa1(n), wa2(n)
      double precision a(nnz), adiag(n), l(nnz+n*p), ldiag(n)
c     *********
c
c     Subroutine dicfs
c
c     Given a symmetric matrix A in compressed column storage, this
c     subroutine computes an incomplete Cholesky factor of A + alpha*D,
c     where alpha is a shift and D is the diagonal matrix with entries
c     set to the l2 norms of the columns of A.
c
c     The subroutine statement is
c
c       subroutine dicfs(n,nnz,a,adiag,acol_ptr,arow_ind,
c                        l,ldiag,lcol_ptr,lrow_ind,
c                        p,alpha,iwa,wa1,wa2)
c
c     where
c
c       n is an integer variable.
c         On entry n is the order of A.
c         On exit n is unchanged.
c
c       nnz is an integer variable.
c         On entry nnz is the number of nonzeros in the strict lower
c            triangular part of A.
c         On exit nnz is unchanged.
c
c       a is a double precision array of dimension nnz.
c         On entry a must contain the strict lower triangular part
c            of A in compressed column storage.
c         On exit a is unchanged.
c
c       adiag is a double precision array of dimension n.
c         On entry adiag must contain the diagonal elements of A.
c         On exit adiag is unchanged.
c
c       acol_ptr is an integer array of dimension n + 1.
c         On entry acol_ptr must contain pointers to the columns of A.
c            The nonzeros in column j of A must be in positions
c            acol_ptr(j), ... , acol_ptr(j+1) - 1.
c         On exit acol_ptr is unchanged.
c
c       arow_ind is an integer array of dimension nnz.
c         On entry arow_ind must contain row indices for the strict
c            lower triangular part of A in compressed column storage.
c         On exit arow_ind is unchanged.
c
c       l is a double precision array of dimension nnz+n*p.
c         On entry l need not be specified.
c         On exit l contains the strict lower triangular part
c            of L in compressed column storage.
c
c       ldiag is a double precision array of dimension n.
c         On entry ldiag need not be specified.
c         On exit ldiag contains the diagonal elements of L.
c
c       lcol_ptr is an integer array of dimension n + 1.
c         On entry lcol_ptr need not be specified.
c         On exit lcol_ptr contains pointers to the columns of L.
c            The nonzeros in column j of L are in the
c            lcol_ptr(j), ... , lcol_ptr(j+1) - 1 positions of l.
c
c       lrow_ind is an integer array of dimension nnz+n*p.
c         On entry lrow_ind need not be specified.
c         On exit lrow_ind contains row indices for the strict lower
c            triangular part of L in compressed column storage.
c
c       p is an integer variable.
c         On entry p specifes the amount of memory available for the
c            incomplete Cholesky factorization.
c         On exit p is unchanged.
c
c       alpha is a double precision variable.
c         On entry alpha is the initial guess of the shift.
c         On exit alpha is final shift
c
c       iwa is an integer work array of dimesnion 3*n.
c
c       wa1 is a double precision work array of dimension n.
c
c       wa2 is a double precision work array of dimension n.
c
c     Subprograms called
c
c       MINPACK-2  ......  dicf
c
c     MINPACK-2 Project. October 1998.
c     Argonne National Laboratory.
c     Chih-Jen Lin and Jorge J. More'.
c
c     **********
      integer nbmax
      parameter(nbmax=3)
      double precision alpham, nbfactor
      parameter(alpham=1.0d-3,nbfactor=512)
      double precision zero, one, two
      parameter(zero=0.0d0,one=1.0d0,two=2.0d0)

      integer i, info, j, k, nb
      double precision alphas

      external dicf

c     Compute the l2 norms of the columns of A.

      do i = 1, n
         wa1(i) = adiag(i)**2
      end do
      do j = 1, n
         do i = acol_ptr(j), acol_ptr(j+1)-1
            k = arow_ind(i)
            wa1(j) = wa1(j) + a(i)**2
            wa1(k) = wa1(k) + a(i)**2
         end do
      end do
      do j = 1, n
         wa1(j) = sqrt(wa1(j))
      end do

c     Compute the scaling matrix D.

      do i = 1, n
         if (wa1(i) .gt. zero) then
            wa2(i) = one/sqrt(wa1(i))
         else
	    wa2(i) = one
         endif
      end do

c     Determine a lower bound for the step.

      if (alpha .le. zero) then
         alphas = alpham
      else
         alphas = alpha
      end if

c     Compute the initial shift.

      alpha = zero
      do i = 1, n
         if (adiag(i) .eq. zero) then
            alpha = alphas
         else
            alpha = max(alpha,-adiag(i)*(wa2(i)**2))
         end if
      end do
      if (alpha .gt. zero) alpha = max(alpha,alphas)

c     Search for an acceptable shift. During the search we decrease
c     the lower bound alphas until we determine a lower bound that
c     is not acceptable. We then increase the shift.
c     The lower bound is decreased by nbfactor at most nbmax times.

      nb = 1
      do while (1 .eq. 1)

c        Copy the sparsity structure of A into L.

         do i = 1, n+1
            lcol_ptr(i) = acol_ptr(i)
         end do
         do i = 1, nnz
            lrow_ind(i) = arow_ind(i)
         end do

c        Scale A and store in the lower triangular matrix L.

         do j = 1, n
            ldiag(j) = adiag(j)*(wa2(j)**2) + alpha
         end do
         do j = 1, n
            do i = acol_ptr(j), acol_ptr(j+1)-1
               l(i) = a(i)*wa2(j)*wa2(arow_ind(i))
            end do
         end do

c        Attempt an incomplete factorization.

         call dicf(n,nnz,l,ldiag,lcol_ptr,lrow_ind,p,info,
     +        iwa(1),iwa(n+1),iwa(2*n+1),wa1)

c        If the factorization exists, then test for termination.
c        Otherwise increment the shift.

         if (info .ge. 0) then

c           If the shift is at the lower bound, reduce the shift.
c           Otherwise undo the scaling of L and exit.

            if (alpha .eq. alphas .and. nb .lt. nbmax) then
               alphas = alphas/nbfactor
               alpha = alphas
               nb = nb + 1
            else
               do i = 1, n
                  ldiag(i) = ldiag(i)/wa2(i)
               end do
               do j = 1, lcol_ptr(n+1)-1
                  l(j) = l(j)/wa2(lrow_ind(j))
               end do
               return
            end if
         else
            alpha = max(two*alpha,alphas)
         end if
      end do

      return

      end


************************************************************************
*
*     Function DNRM2              Called by: DGQTST,DHUMIT,DLSVMN
*
*     for special case of INCX=1
*
*     return the euclidean norm of a vector, so that
*
*     DNRM2 := sqrt( x'*x )
*
*
*  -- This version written on 25-October-1982.
*     Modified on 14-October-1993 to inline the call to DLASSQ.
*     Sven Hammarling, Nag Ltd.
*
************************************************************************
      DOUBLE PRECISION FUNCTION DNRM2(N,X)
*
*     function arguments
*
      INTEGER*4 N
      DOUBLE PRECISION X(*)
*
*     local vars
*
      INTEGER*4 I
      DOUBLE PRECISION ABSXI,SCALE,SSQ
*
*
*
      IF (N.LT.1) THEN
         DNRM2 = 0.D0
      ELSEIF (N.EQ.1) THEN
         DNRM2 = ABS(X(1))
      ELSE
         SCALE = 0.D0
         SSQ = 1.D0
*
*        The following loop is equivalent to this call in the LAPACK
*        auxiliary routine: CALL DLASSQ(N,X,INCX,SCALE,SSQ)
*
         DO 10 I=1,1+(N-1),1
            IF (X(I).NE.0.D0) THEN
               ABSXI = ABS(X(I))
               IF (SCALE.LT.ABSXI) THEN
                  SSQ = 1.D0 + SSQ*(SCALE/ABSXI)**2
                  SCALE = ABSXI
               ELSE
                  SSQ = SSQ + (ABSXI/SCALE)**2
               ENDIF
            ENDIF
   10    CONTINUE
         DNRM2  = SCALE * SQRT(SSQ)
      ENDIF

      RETURN
      END


      subroutine dicfs(n,nnz,a,adiag,acol_ptr,arow_ind,
     +                 l,ldiag,lcol_ptr,lrow_ind,
     +                 p,alpha,iwa,wa1,wa2)
      integer n, nnz, p
      integer acol_ptr(n+1), arow_ind(nnz)
      integer lcol_ptr(n+1), lrow_ind(nnz+n*p)
      integer iwa(3*n)
      double precision alpha
      double precision wa1(n), wa2(n)
      double precision a(nnz), adiag(n), l(nnz+n*p), ldiag(n)
c     *********
c
c     Subroutine dicfs
c
c     Given a symmetric matrix A in compressed column storage, this
c     subroutine computes an incomplete Cholesky factor of A + alpha*D,
c     where alpha is a shift and D is the diagonal matrix with entries
c     set to the l2 norms of the columns of A.
c
c     The subroutine statement is
c
c       subroutine dicfs(n,nnz,a,adiag,acol_ptr,arow_ind,
c                        l,ldiag,lcol_ptr,lrow_ind,
c                        p,alpha,iwa,wa1,wa2)
c
c     where
c
c       n is an integer variable.
c         On entry n is the order of A.
c         On exit n is unchanged.
c
c       nnz is an integer variable.
c         On entry nnz is the number of nonzeros in the strict lower
c            triangular part of A.
c         On exit nnz is unchanged.
c
c       a is a double precision array of dimension nnz.
c         On entry a must contain the strict lower triangular part
c            of A in compressed column storage.
c         On exit a is unchanged.
c
c       adiag is a double precision array of dimension n.
c         On entry adiag must contain the diagonal elements of A.
c         On exit adiag is unchanged.
c
c       acol_ptr is an integer array of dimension n + 1.
c         On entry acol_ptr must contain pointers to the columns of A.
c            The nonzeros in column j of A must be in positions
c            acol_ptr(j), ... , acol_ptr(j+1) - 1.
c         On exit acol_ptr is unchanged.
c
c       arow_ind is an integer array of dimension nnz.
c         On entry arow_ind must contain row indices for the strict
c            lower triangular part of A in compressed column storage.
c         On exit arow_ind is unchanged.
c
c       l is a double precision array of dimension nnz+n*p.
c         On entry l need not be specified.
c         On exit l contains the strict lower triangular part
c            of L in compressed column storage.
c
c       ldiag is a double precision array of dimension n.
c         On entry ldiag need not be specified.
c         On exit ldiag contains the diagonal elements of L.
c
c       lcol_ptr is an integer array of dimension n + 1.
c         On entry lcol_ptr need not be specified.
c         On exit lcol_ptr contains pointers to the columns of L.
c            The nonzeros in column j of L are in the
c            lcol_ptr(j), ... , lcol_ptr(j+1) - 1 positions of l.
c
c       lrow_ind is an integer array of dimension nnz+n*p.
c         On entry lrow_ind need not be specified.
c         On exit lrow_ind contains row indices for the strict lower
c            triangular part of L in compressed column storage.
c
c       p is an integer variable.
c         On entry p specifes the amount of memory available for the
c            incomplete Cholesky factorization.
c         On exit p is unchanged.
c
c       alpha is a double precision variable.
c         On entry alpha is the initial guess of the shift.
c         On exit alpha is final shift
c
c       iwa is an integer work array of dimesnion 3*n.
c
c       wa1 is a double precision work array of dimension n.
c
c       wa2 is a double precision work array of dimension n.
c
c     Subprograms called
c
c       MINPACK-2  ......  dicf
c
c     MINPACK-2 Project. October 1998.
c     Argonne National Laboratory.
c     Chih-Jen Lin and Jorge J. More'.
c
c     **********
      integer nbmax
      parameter(nbmax=3)
      double precision alpham, nbfactor
      parameter(alpham=1.0d-3,nbfactor=512)
      double precision zero, one, two
      parameter(zero=0.0d0,one=1.0d0,two=2.0d0)

      integer i, info, j, k, nb
      double precision alphas

      external dicf

c     Compute the l2 norms of the columns of A.

      do i = 1, n
         wa1(i) = adiag(i)**2
      end do
      do j = 1, n
         do i = acol_ptr(j), acol_ptr(j+1)-1
            k = arow_ind(i)
            wa1(j) = wa1(j) + a(i)**2
            wa1(k) = wa1(k) + a(i)**2
         end do
      end do
      do j = 1, n
         wa1(j) = sqrt(wa1(j))
      end do

c     Compute the scaling matrix D.

      do i = 1, n
         if (wa1(i) .gt. zero) then
            wa2(i) = one/sqrt(wa1(i))
         else
	    wa2(i) = one
         endif
      end do

c     Determine a lower bound for the step.

      if (alpha .le. zero) then
         alphas = alpham
      else
         alphas = alpha
      end if

c     Compute the initial shift.

      alpha = zero
      do i = 1, n
         if (adiag(i) .eq. zero) then
            alpha = alphas
         else
            alpha = max(alpha,-adiag(i)*(wa2(i)**2))
         end if
      end do
      if (alpha .gt. zero) alpha = max(alpha,alphas)

c     Search for an acceptable shift. During the search we decrease
c     the lower bound alphas until we determine a lower bound that
c     is not acceptable. We then increase the shift.
c     The lower bound is decreased by nbfactor at most nbmax times.

      nb = 1
      do while (1 .eq. 1)

c        Copy the sparsity structure of A into L.

         do i = 1, n+1
            lcol_ptr(i) = acol_ptr(i)
         end do
         do i = 1, nnz
            lrow_ind(i) = arow_ind(i)
         end do

c        Scale A and store in the lower triangular matrix L.

         do j = 1, n
            ldiag(j) = adiag(j)*(wa2(j)**2) + alpha
         end do
         do j = 1, n
            do i = acol_ptr(j), acol_ptr(j+1)-1
               l(i) = a(i)*wa2(j)*wa2(arow_ind(i))
            end do
         end do

c        Attempt an incomplete factorization.

         call dicf(n,nnz,l,ldiag,lcol_ptr,lrow_ind,p,info,
     +        iwa(1),iwa(n+1),iwa(2*n+1),wa1)

c        If the factorization exists, then test for termination.
c        Otherwise increment the shift.

         if (info .ge. 0) then

c           If the shift is at the lower bound, reduce the shift.
c           Otherwise undo the scaling of L and exit.

            if (alpha .eq. alphas .and. nb .lt. nbmax) then
               alphas = alphas/nbfactor
               alpha = alphas
               nb = nb + 1
            else
               do i = 1, n
                  ldiag(i) = ldiag(i)/wa2(i)
               end do
               do j = 1, lcol_ptr(n+1)-1
                  l(j) = l(j)/wa2(lrow_ind(j))
               end do
               return
            end if
         else
            alpha = max(two*alpha,alphas)
         end if
      end do

      return

      end

      subroutine dstrsol(n,l,ldiag,jptr,indr,r,task)
      character*60 task
      integer n
      integer jptr(n+1), indr(*)
      double precision l(*), ldiag(n), r(n)
c     **********
c
c     Subroutine dstrsol
c
c     This subroutine solves the triangular systems L*x = r or L'*x = r.
c
c     The subroutine statement is
c
c       subroutine dstrsol(n,l,ldiag,jptr,indr,r,task)
c
c     where
c
c       n is an integer variable.
c         On entry n is the order of L.
c         On exit n is unchanged.
c
c       l is a double precision array of dimension *.
c         On entry l must contain the nonzeros in the strict lower
c            triangular part of L in compressed column storage.
c         On exit l is unchanged.
c
c       ldiag is a double precision array of dimension n.
c         On entry ldiag must contain the diagonal elements of L.
c         On exit ldiag is unchanged.
c
c       jptr is an integer array of dimension n + 1.
c         On entry jptr must contain pointers to the columns of A.
c            The nonzeros in column j of A must be in positions
c            jptr(j), ... , jptr(j+1) - 1.
c         On exit jptr is unchanged.
c
c       indr is an integer array of dimension *.
c         On entry indr must contain row indices for the strict
c            lower triangular part of L in compressed column storage.
c         On exit indr is unchanged.
c
c       r is a double precision array of dimension n.
c         On entry r must contain the vector r.
c         On exit r contains the solution vector x.
c
c       task is a character variable of length 60.
c         On entry
c            task(1:1) = 'N' if we need to solve L*x = r
c            task(1:1) = 'T' if we need to solve L'*x = r
c         On exit task is unchanged.
c
c     MINPACK-2 Project. May 1998.
c     Argonne National Laboratory.
c
c     **********
      double precision zero
      parameter(zero=0.0d0)

      integer j,k
      double precision temp

c     Solve L*x =r and store the result in r.

      if (task(1:1) .eq. 'N') then

         do j = 1, n
            temp = r(j)/ldiag(j)
            do k = jptr(j), jptr(j+1) - 1
               r(indr(k)) = r(indr(k)) - l(k)*temp
            end do
            r(j) = temp
         end do

         return

      end if

c     Solve L'*x =r and store the result in r.

      if (task(1:1) .eq. 'T') then

         r(n) = r(n)/ldiag(n)
         do j = n - 1, 1, -1
            temp = zero
            do k = jptr(j), jptr(j+1) - 1
               temp = temp + l(k)*r(indr(k))
            end do
            r(j) = (r(j) - temp)/ldiag(j)
         end do

         return

      end if

      end
      subroutine dicf(n,nnz,a,diag,col_ptr,row_ind,p,info,
     +                indr,indf,list,w)
      integer n, nnz, p, info
      integer col_ptr(n+1), row_ind(*)
      integer indr(n), indf(n), list(n)
      double precision a(*), diag(n)
      double precision w(n)
c     *********
c
c     Subroutine dicf
c
c     Given a sparse symmetric matrix A in compressed row storage,
c     this subroutine computes an incomplete Cholesky factorization.
c
c     Implementation of dicf is based on the Jones-Plassmann code.
c     Arrays indf and list define the data structure.
c     At the beginning of the computation of the j-th column,
c
c       For k < j, indf(k) is the index of a for the first
c       nonzero l(i,k) in the k-th column with i >= j.
c
c       For k < j, list(i) is a pointer to a linked list of column
c       indices k with i = row_ind(indf(k)).
c
c     For the computation of the j-th column, the array indr records
c     the row indices. Hence, if nlj is the number of nonzeros in the
c     j-th column, then indr(1),...,indr(nlj) are the row indices.
c     Also, for i > j, indf(i) marks the row indices in the j-th
c     column so that indf(i) = 1 if l(i,j) is not zero.
c
c     The subroutine statement is
c
c       subroutine dicf(n,nnz,a,diag,col_ptr,row_ind,p,info,
c                       indr,indf,list,w)
c
c     where
c
c       n is an integer variable.
c         On entry n is the order of A.
c         On exit n is unchanged.
c
c       nnz is an integer variable.
c         On entry nnz is the number of nonzeros in the strict lower
c            triangular part of A.
c         On exit nnz is unchanged.
c
c       a is a double precision array of dimension nnz+n*p.
c         On entry the first nnz entries of a must contain the strict
c            lower triangular part of A in compressed column storage.
c         On exit a contains the strict lower triangular part
c            of L in compressed column storage.
c
c       diag is a double precision array of dimension n.
c         On entry diag must contain the diagonal elements of A.
c         On exit diag contains the diagonal elements of L.
c
c       col_ptr is an integer array of dimension n + 1.
c         On entry col_ptr must contain pointers to the columns of A.
c            The nonzeros in column j of A must be in positions
c            col_ptr(j), ... , col_ptr(j+1) - 1.
c         On exit col_ptr contains pointers to the columns of L.
c            The nonzeros in column j of L are in the
c            col_ptr(j), ... , col_ptr(j+1) - 1 positions of l.
c
c       row_ind is an integer array of dimension nnz+n*p.
c         On entry row_ind must contain row indices for the strict
c            lower triangular part of A in compressed column storage.
c         On exit row_ind contains row indices for the strict lower
c            triangular part of L in compressed column storage.
c
c       p is an integer variable.
c         On entry p specifes the amount of memory available for the
c            incomplete Cholesky factorization.
c         On exit p is unchanged.
c
c       info is an integer variable.
c         On entry info need not be specified.
c         On exit info = 0 if the factorization succeeds, and
c            info < 0 if the -info pivot is not positive.
c
c       indr is an integer work array of dimension n.
c
c       indf is an integer work array of dimension n.
c
c       list is an integer work array of dimension n.
c
c       w is a double precision work array of dimension n.
c
c     Subprograms called
c
c       MINPACK-2  ......  dsel2, ihsort, insort
c
c       Level 1 BLAS  ...  daxpy, dcopy, ddot, dnrm2
c
c     MINPACK-2 Project. May 1998.
c     Argonne National Laboratory.
c     Chih-Jen Lin and Jorge J. More'.
c
c     **********
      integer insortf
      parameter (insortf=20)
      double precision zero
      parameter (zero=0.0d0)

      integer i, ip, j, k, kth, nlj, newk, np, mlj
      integer isj, iej, isk, iek, newisj, newiej
      double precision lval

      external dsel2, ihsort, insort

      info = 0
      do j = 1, n
         indf(j) = 0
         list(j) = 0
      end do

c     Make room for L by moving A to the last n*p positions in a.

      np = n*p
      do  j = 1, n + 1
         col_ptr(j) = col_ptr(j) + np
      end do
      do j = nnz, 1, -1
         row_ind(np+j) = row_ind(j)
         a(np+j) = a(j)
      end do

c     Compute the incomplete Cholesky factorization.

      isj = col_ptr(1)
      col_ptr(1) = 1
      do j = 1, n

c        Load column j into the array w. The first and last elements
c        of the j-th column of A are a(isj) and a(iej).

         nlj = 0
         iej = col_ptr(j+1) - 1
         do ip = isj, iej
            i = row_ind(ip)
            w(i) = a(ip)
            nlj = nlj + 1
            indr(nlj) = i
            indf(i) = 1
         end do

c        Exit if the current pivot is not positive.

         if (diag(j) .le. zero) then
            info = -j
            return
         end if
         diag(j) = sqrt(diag(j))

c        Update column j using the previous columns.

         k = list(j)
         do while (k .ne. 0)
            isk = indf(k)
            iek = col_ptr(k+1) - 1

c           Set lval to l(j,k).

            lval = a(isk)

c           Update indf and list.

            newk = list(k)
            isk = isk + 1
            if (isk .lt. iek) then
               indf(k) = isk
               list(k) = list(row_ind(isk))
               list(row_ind(isk)) = k
            endif
            k = newk

c           Compute the update a(i,i) <- a(i,j) - l(i,k)*l(j,k).
c           In this loop we pick up l(i,k) for k < j and i > j.

            do ip = isk, iek
               i = row_ind(ip)
               if (indf(i) .ne. 0) then
                  w(i) = w(i) - lval*a(ip)
               else
                  indf(i) = 1
                  nlj = nlj + 1
                  indr(nlj) = i
                  w(i) = - lval*a(ip)
               end if
            end do
         end do

c        Compute the j-th column of L.

         do k = 1, nlj
            w(indr(k)) = w(indr(k))/diag(j)
         end do

c        Set mlj to the number of nonzeros to be retained.

         mlj = min(iej-isj+1+p,nlj)
         kth = nlj - mlj + 1

        if (nlj .ge. 1) then

c           Determine the kth smallest elements in the current
c           column, and hence, the largest mlj elements.

            call dsel2(nlj,w,indr,kth)

c           Sort the row indices of the selected elements. Insertion
c           sort is used for small arrays, and heap sort for larger
c           arrays. The sorting of the row indices is required so that
c           we can retrieve l(i,k) with i > k from indf(k).

            if (mlj .le. insortf) then
               call insort(mlj,indr(kth))
            else
               call ihsort(mlj,indr(kth))
            end if
         end if

c        Store the largest elements in L. The first and last elements
c        of the j-th column of L are a(newisj) and a(newiej).

         newisj = col_ptr(j)
         newiej = newisj + mlj -1
         do k = newisj, newiej
            a(k) = w(indr(k-newisj+kth))
            row_ind(k) = indr(k-newisj+kth)
         end do

c        Update the diagonal elements.

         do k = kth, nlj
            diag(indr(k)) = diag(indr(k)) - w(indr(k))**2
         end do

c        Update indf and list for the j-th column.

         if (newisj .lt. newiej) then
            indf(j) = newisj
            list(j) = list(row_ind(newisj))
            list(row_ind(newisj)) = j
         endif

c        Clear out elements j+1,...,n of the array indf.

         do k = 1, nlj
            indf(indr(k)) = 0
         end do

c        Update isj and col_ptr.

         isj = col_ptr(j+1)
         col_ptr(j+1) = newiej + 1

      end do

      return

      end

      subroutine insort(n,keys)
      integer n
      integer keys(n)
c     **********
c
c     Subroutine insort
c
c     Given an integer array keys of length n, this subroutine uses
c     an insertion sort to sort the keys in increasing order.
c
c     The subroutine statement is
c
c       subroutine insort(n,keys)
c
c     where
c
c       n is an integer variable.
c         On entry n is the number of keys.
c         On exit n is unchanged.
c
c       keys is an integer array of length n.
c         On entry keys is the array to be sorted.
c         On exit keys is permuted to increasing order.
c
c     MINPACK-2 Project. March 1998.
c     Argonne National Laboratory.
c     Chih-Jen Lin and Jorge J. More'.
c
c     **********
      integer i, j, ind

      do j = 2, n
         ind = keys(j)
         i = j - 1
         do while (i .gt. 0 .and. keys(i) .gt. ind)
            keys(i+1) = keys(i)
            i = i - 1
         end do
         keys(i+1) = ind
      end do

      return

      end
      subroutine ihsort(n,keys)
      integer n
      integer keys(n)
c     **********
c
c     Subroutine ihsort
c
c     Given an integer array keys of length n, this subroutine uses
c     a heap sort to sort the keys in increasing order.
c
c     This subroutine is a minor modification of code written by
c     Mark Jones and Paul Plassmann.
c
c     The subroutine statement is
c
c       subroutine ihsort(n,keys)
c
c     where
c
c       n is an integer variable.
c         On entry n is the number of keys.
c         On exit n is unchanged.
c
c       keys is an integer array of length n.
c         On entry keys is the array to be sorted.
c         On exit keys is permuted to increasing order.
c
c     MINPACK-2 Project. March 1998.
c     Argonne National Laboratory.
c     Chih-Jen Lin and Jorge J. More'.
c
c     **********
      integer k, m, lheap, rheap, mid
      integer x

      if (n. le. 1) return

c     Build the heap.

      mid = n/2
      do k = mid, 1, -1
         x = keys(k)
         lheap = k
         rheap = n
         m = lheap*2
         do while (m .le. rheap)
            if (m .lt. rheap) then
               if (keys(m) .lt. keys(m+1)) m = m + 1
            endif
            if (x .ge. keys(m)) then
               m = rheap + 1
            else
               keys(lheap) = keys(m)
               lheap = m
               m = 2*lheap
            end if
         end do
      keys(lheap) = x
      end do

c     Sort the heap.

      do k = n, 2, -1
         x = keys(k)
         keys(k) = keys(1)
         lheap = 1
         rheap = k-1
         m = 2
         do while (m .le. rheap)
            if (m .lt. rheap) then
               if (keys(m) .lt. keys(m+1)) m = m+1
            endif
            if (x .ge. keys(m)) then
               m = rheap + 1
            else
               keys(lheap) = keys(m)
               lheap = m
               m = 2*lheap
            end if
         end do
      keys(lheap) = x
      end do

      return

      end
      subroutine dsel2(n,x,keys,k)
      integer n, k
      integer keys(n)
      double precision x(n)
c     **********
c
c     Subroutine dsel2
c
c     Given an array x of length n, this subroutine permutes
c     the elements of the array keys so that
c
c       abs(x(keys(i))) <= abs(x(keys(k))),  1 <= i <= k,
c       abs(x(keys(k))) <= abs(x(keys(i))),  k <= i <= n.
c
c     In other words, the smallest k elements of x in absolute value are
c     x(keys(i)), i = 1,...,k, and x(keys(k)) is the kth smallest element.
c
c     The subroutine statement is
c
c       subroutine dsel2(n,x,keys,k)
c
c     where
c
c       n is an integer variable.
c         On entry n is the number of keys.
c         On exit n is unchanged.
c
c       x is a double precision array of length n.
c         On entry x is the array to be sorted.
c         On exit x is unchanged.
c
c       keys is an integer array of length n.
c         On entry keys is the array of indices for x.
c         On exit keys is permuted so that the smallest k elements
c            of x in absolute value are x(keys(i)), i = 1,...,k, and
c            x(keys(k)) is the kth smallest element.
c
c       k is an integer.
c         On entry k specifes the kth largest element.
c         On exit k is unchanged.
c
c     MINPACK-2 Project. March 1998.
c     Argonne National Laboratory.
c     William D. Kastak, Chih-Jen Lin, and Jorge J. More'.
c
c     **********
      integer i, l, lc, lp, m, p, p1, p2, p3, u
      integer swap

      if (n .le. 1 .or. k .le. 0 .or. k .gt. n) return

      u = n
      l = 1
      lc = n
      lp = 2*n

c     Start of iteration loop.

      do while (l .lt. u)

c        Choose the partition as the median of the elements in
c        positions l+s*(u-l) for s = 0, 0.25, 0.5, 0.75, 1.
c        Move the partition element into position l.

         p1 = (u+3*l)/4
         p2 = (u+l)/2
         p3 = (3*u+l)/4

c        Order the elements in positions l and p1.

         if (dabs(x(keys(l))) .gt. dabs(x(keys(p1)))) then
            swap = keys(l)
            keys(l) = keys(p1)
            keys(p1) = swap
            end if

c        Order the elements in positions p2 and p3.

         if (dabs(x(keys(p2))) .gt. dabs(x(keys(p3)))) then
            swap = keys(p2)
            keys(p2) = keys(p3)
            keys(p3) = swap
            end if

c        Swap the larger of the elements in positions p1
c        and p3, with the element in position u, and reorder
c        the first two pairs of elements as necessary.

         if (dabs(x(keys(p3))) .gt. dabs(x(keys(p1)))) then
            swap = keys(p3)
            keys(p3) = keys(u)
            keys(u) = swap
            if (dabs(x(keys(p2))) .gt. dabs(x(keys(p3)))) then
               swap = keys(p2)
               keys(p2) = keys(p3)
               keys(p3) = swap
               end if
         else
            swap = keys(p1)
            keys(p1) = keys(u)
            keys(u) = swap
            if (dabs(x(keys(l))) .gt. dabs(x(keys(p1)))) then
               swap = keys(l)
               keys(l) = keys(p1)
               keys(p1) = swap
               end if
            end if

c        If we define a(i) = abs(x(keys(i)) for i = 1,..., n, we have
c        permuted keys so that
c
c          a(l) <= a(p1), a(p2) <= a(p3), max(a(p1),a(p3)) <= a(u).
c
c        Find the third largest element of the four remaining
c        elements (the median), and place in position l.

         if (dabs(x(keys(p1))) .gt. dabs(x(keys(p3)))) then
            if (dabs(x(keys(l))) .le. dabs(x(keys(p3)))) then
               swap = keys(l)
               keys(l) = keys(p3)
               keys(p3) = swap
               end if
         else
            if (dabs(x(keys(p2))) .le. dabs(x(keys(p1)))) then
               swap = keys(l)
               keys(l) = keys(p1)
               keys(p1) = swap
            else
               swap = keys(l)
               keys(l) = keys(p2)
               keys(p2) = swap
               end if
            end if

c        Partition the array about the element in position l.

         m = l
         do i = l+1, u
            if (dabs(x(keys(i))) .lt. dabs(x(keys(l))))then
               m = m + 1
               swap = keys(m)
               keys(m) = keys(i)
               keys(i) = swap
               end if
         end do

c        Move the partition element into position m.

         swap = keys(l)
         keys(l) = keys(m)
         keys(m) = swap

c        Adjust the values of l and u.

         if (k .ge. m) l = m + 1
         if (k .le. m) u = m - 1

c        Check for multiple medians if the length of the subarray
c        has not decreased by 1/3 after two consecutive iterations.

         if (3*(u-l) .gt. 2*lp .and. k .gt. m) then

c           Partition the remaining elements into those elements
c           equal to x(m), and those greater than x(m). Adjust
c           the values of l and u.

            p = m
            do i = m+1, u
               if (dabs(x(keys(i))) .eq. dabs(x(keys(m)))) then
                  p = p + 1
                  swap = keys(p)
                  keys(p) = keys(i)
                  keys(i) = swap
                  end if
            end do
            l = p + 1
            if (k .le. p) u = p - 1
            end if

c        Update the length indicators for the subarray.

         lp = lc
         lc = u-l

      end do

      return

      end


module histogram
  implicit none
  private
  double precision, public :: h ! distance between 2 bins
  integer, public :: bin(180) ! 100 bins of length h
  public :: init
contains
  subroutine init(len)
    implicit none
    double precision, intent(in) :: len
    double precision :: maxrange
    maxrange = len*sqrt(3.)/2.
    if(size(bin)<=0) stop "size(bin) must not be <=0"
    h = maxrange/size(bin)
  end subroutine init
end module histogram

program lasvegas
  use histogram, only: h, bin, histogram_init=>init
  use ewald, only: ewald_init, ewald_energy
  implicit none
  integer, parameter :: N=128 ! number of molecules
  integer, parameter :: mcstepmax=10**5 ! number of MonteCarlo steps
  double precision, parameter :: len=15.6664 ! Supercell length in angstroms
  double precision, parameter :: targetacceptanceratio = 0.4
  integer :: i, j, mcstep, k, l
  double precision :: rxO(N), ryO(N), rzO(N), rxH1(N), ryH1(N), rzH1(N), rxH2(N), ryH2(N), rzH2(N) ! cartesian coordinates of all N molecules
  ! WATER MODEL: SPC/E by Berendsen et al. JCP 1987
  double precision, parameter :: rO_molecularframe(3)=[0.,0.,0.]
  double precision, parameter :: rH1_molecularframe(3)=[ 0.816495,0.,0.5773525]
  double precision, parameter :: rH2_molecularframe(3)=[-0.816495,0.,0.5773525]
  double precision, parameter :: qH=0.42380, qO=-2.*qH
  double precision, parameter :: eps=0.65 ! kJ/mol
  double precision, parameter :: sig=3.166 ! Angstroms

  double precision, parameter :: sig6=sig**6, sig12=sig**12
  double precision :: r6, r12, dx, dy, dz, Uij, dr, drmax, rand, rand3(3), du, dub, ratio, r
  double precision :: rO(3), rH1(3), rH2(3), rO_tr(3), rH1_tr(3), rH2_tr(3), rO_tr_rot(3), rH1_tr_rot(3), rH2_tr_rot(3)
  integer :: ntrial, naccpt, ibin
  integer, parameter :: nadjst=10**3
  double precision, parameter :: temperature = 300 ! K
  double precision, parameter :: boltzmanncst = 8.3144621e-3 ! kJ/(mol K)
  double precision, parameter :: beta=1./(boltzmanncst*temperature)
  double precision, parameter :: halflen=len/2.
  ! CODATA 2010 physical constants
  double precision, parameter :: pi=acos(-1.d0)
  double precision :: q0, q1, q2, q3 ! quaternion used to easily define the rotation matrix
  double precision :: a11,a12,a13,a21,a22,a23,a31,a32,a33
  double precision :: q(3*N), rx(3*N), ry(3*N), rz(3*N)
  double precision :: Uewald, Ulj, Utot, UewaldBEFORE, UewaldAFTER, dUewald

  call print_header
  call random_seed()
  drmax = sig/2.
  ntrial = 0
  naccpt = 0
  call histogram_init(len)
  call positions_init

  ! Total potential energy of the system
  ! ====================================
  ! 1/ Lennard-Jones
  Ulj = 0
  do i=1,N-1
    do j=i+1,N
      dx = abs(rxO(i)-rxO(j))
      if( dx>halflen ) dx=len-dx ! pbc
      dy = abs(ryO(i)-ryO(j))
      if( dy>halflen ) dy=len-dy
      dz = abs(rzO(i)-rzO(j))
      if( dz>halflen ) dz=len-dz
      r6 = (dx**2 + dy**2 + dz**2)**3
      r12 = r6**2
      Ulj = Ulj + 4*eps*( sig12/r12 - sig6/r6 )
    end do
  end do
  Ulj = Ulj ! /kb ?
print*,"Ulj initial=",Ulj

  ! 2/ Electrostatics
  call fill_q
  call fill_positions
  call ewald_init (len)
  call ewald_energy (N,len,q,rx,ry,rz,Uewald)
print*,"Uewald initial =",Uewald

  open(43,file="internal-energy.dat")
  write(43,*) Ulj+Uewald, Ulj, Uewald

  ! Monte Carlo Metropolis steps
  ! ============================
  do mcstep=1,mcstepmax

    ! randomnly select a particle i between 1 and N
    call random_number(rand) ! u real in [0,1[
    i = 1 + floor(N*rand)    ! i integer in {1,...,N}
    rO  = [rxO(i),ryO(i),rzO(i)]
    rH1 = [rxH1(i),ryH1(i),rzH1(i)]
    rH2 = [rxH2(i),ryH2(i),rzH2(i)]

    ! displace x coordinate of particle i by a random umount, dx
    ! dx = drmax*u, where u is a uniform random variate in [-0.5:0.5]
    call random_number(rand3)
    rO_tr  = rO  + drmax*(2*rand3-1)! _tr means translated

    ! rotate molecule by a random quantity
    ! ====================================
    call generate_random_quaternion (q0,q1,q2,q3)
    ! rotation matrix
    a11=q0**2+q1**2-q2**2-q3**2; a12=2*(q1*q2+q0*q3)        ; a13=2*(-q0*q2+q1*q3)
    a21=2*(q1*q2-q0*q3)        ; a22=q0**2-q1**2+q2**2-q3**2; a23=2*(q0*q1+q2*q3)
    a31=2*(q0*q2+q1*q3)        ; a32=2*(-q0*q1+q2*q3)       ; a33=q0**2-q1**2-q2**2+q3**2
    ! apply rotation matrix (1/ translate center of mass to origin of lab frame, 2/ apply rotation matrix, 3/ translate back to original position)
    rO_tr_rot     = modulo( rO_tr, len)
    rH1_tr_rot(1) = a11*rH1(1) + a12*rH1(2) + a13*rH1(3)
    rH1_tr_rot(2) = a21*rH1(1) + a22*rH1(2) + a23*rH1(3)
    rH1_tr_rot(3) = a31*rH1(1) + a32*rH1(2) + a33*rH1(3)
    rH2_tr_rot(1) = a11*rH2(1) + a12*rH2(2) + a13*rH2(3)
    rH2_tr_rot(2) = a21*rH2(1) + a22*rH2(2) + a23*rH2(3)
    rH2_tr_rot(3) = a31*rH2(1) + a32*rH2(2) + a33*rH2(3)

    ! compute variation in energy
    du = 0
    do j=1,N
      ! add new contribution to LJ
      if( j==i ) cycle
      dx = abs(rO_tr_rot(1)-rxO(j))
      if( dx>halflen ) dx=len-dx
      dy = abs(rO_tr_rot(2)-ryO(j))
      if( dy>halflen ) dy=len-dy
      dz = abs(rO_tr_rot(3)-rzO(j))
      if( dz>halflen ) dz=len-dz
      r6 = (dx**2 + dy**2 + dz**2)**3
      r12 = r6**2
      Uij = 4*eps*( sig12/r12 - sig6/r6 )
      du = du + Uij
      ! remove old contribution
      dx = abs(rxO(i)-rxO(j))
      if( dx>halflen ) dx=len-dx
      dy = abs(ryO(i)-ryO(j))
      if( dy>halflen ) dy=len-dy
      dz = abs(rzO(i)-rzO(j))
      if( dz>halflen ) dz=len-dz
      r6 = (dx**2 + dy**2 + dz**2)**3
      r12 = r6**2
      Uij = 4*eps*( sig12/r12 - sig6/r6 )
      du = du -Uij
    end do

    j=0
    do l=1,N
      j=j+1
      rx(j)=rxO(l)
      ry(j)=ryO(l)
      rz(j)=rzO(l)
      j=j+1
      rx(j)=rxO(l)+rxH1(l)
      ry(j)=ryO(l)+ryH1(l)
      rz(j)=rzO(l)+rzH1(l)
      j=j+1
      rx(j)=rxO(l)+rxH2(l)
      ry(j)=ryO(l)+ryH2(l)
      rz(j)=rzO(l)+rzH2(l)
    end do
    call ewald_energy (N,len,q,rx,ry,rz,UewaldBEFORE)

    j=0
    do l=1,N
      if (l/=i) then
        j=j+1
        rx(j)=rxO(l)
        ry(j)=ryO(l)
        rz(j)=rzO(l)
        j=j+1
        rx(j)=rxO(l)+rxH1(l)
        ry(j)=ryO(l)+ryH1(l)
        rz(j)=rzO(l)+rzH1(l)
        j=j+1
        rx(j)=rxO(l)+rxH2(l)
        ry(j)=ryO(l)+ryH2(l)
        rz(j)=rzO(l)+rzH2(l)
      else if(l==i) then
        j=j+1
        rx(j)=rO_tr_rot(1)
        ry(j)=rO_tr_rot(2)
        rz(j)=rO_tr_rot(3)
        j=j+1
        rx(j)=rO_tr_rot(1)+rH1_tr_rot(1)
        ry(j)=rO_tr_rot(2)+rH1_tr_rot(2)
        rz(j)=rO_tr_rot(3)+rH1_tr_rot(3)
        j=j+1
        rx(j)=rO_tr_rot(1)+rH2_tr_rot(1)
        ry(j)=rO_tr_rot(2)+rH2_tr_rot(2)
        rz(j)=rO_tr_rot(3)+rH2_tr_rot(3)
      end if
    end do
    call ewald_energy (N,len,q,rx,ry,rz,UewaldAFTER)

    dub = (du+UewaldAFTER-UewaldBEFORE) * beta
    ! Metropolis algorithm
    if( dub <= 0 ) then ! always accept
      ! print*,"dub<=0  =>accpt"
      Utot = Utot + du
      rxO(i) = rO_tr_rot(1)
      ryO(i) = rO_tr_rot(2)
      rzO(i) = rO_tr_rot(3)
      rxH1(i) = rH1_tr_rot(1)
      ryH1(i) = rH1_tr_rot(2)
      rzH1(i) = rH1_tr_rot(3)
      rxH2(i) = rH2_tr_rot(1)
      ryH2(i) = rH2_tr_rot(2)
      rzH2(i) = rH2_tr_rot(3)
      naccpt = naccpt +1
    else
      call random_number(rand)
      if( exp(-dub) > rand ) then
        Utot = Utot + du
        rxO(i) = rO_tr_rot(1)
        ryO(i) = rO_tr_rot(2)
        rzO(i) = rO_tr_rot(3)
        rxH1(i) = rH1_tr_rot(1)
        ryH1(i) = rH1_tr_rot(2)
        rzH1(i) = rH1_tr_rot(3)
        rxH2(i) = rH2_tr_rot(1)
        ryH2(i) = rH2_tr_rot(2)
        rzH2(i) = rH2_tr_rot(3)
        naccpt = naccpt +1
      end if
    end if

    if(modulo(ntrial,100)==0) write(43,*) Utot, Ulj, Uewald

    ntrial = ntrial + 1
    if( modulo(ntrial,nadjst)==0 ) then
      ratio = real(naccpt)/real(nadjst)
      if( ratio > targetacceptanceratio ) then
        drmax = drmax * 1.05
      else
        drmax = drmax * 0.95
      end if
      naccpt = 0
      print*,"progress(%)",floor(real(ntrial)/real(mcstepmax)*100)
      if(abs((ratio-targetacceptanceratio)/targetacceptanceratio)>0.2) print*,"WARNING: accpt ratio=",&
        real(ratio,4),"only. Target=>0.3"
    end if

    ! print positions once system has been equilibrated mcstepmax/10 times
    if(ntrial == mcstepmax/10) then
      open(38,file="positions_equilibrated.dat")
      write(38,*) 3*N ! N, which is an integer parameter that should not be read
      write(38,*)"configuration after equilibration. Box length is",len
      do i=1,N ! 3 sites per molecule
        write(38,*)"O",rxO(i),ryO(i),rzO(i)
        write(38,*)"H",[rxO(i),ryO(i),rzO(i)]+[rxH1(i),ryH1(i),rzH1(i)]
        write(38,*)"H",[rxO(i),ryO(i),rzO(i)]+[rxH2(i),ryH2(i),rzH2(i)]
      end do
      close(38)
      print*,"positions_equilibrated.dat written"
    end if

    ! update histogram for the center of mass
    if(ntrial > mcstepmax/10) then ! trick to not accumulate stats before "melting". Much smarter tricks could be used.
      do i=1,N
        do j=1,N
          if (j/=i) then
            dx = abs(rxO(i)-rxO(j))
            if( dx>halflen ) dx=len-dx
            dy = abs(ryO(i)-ryO(j))
            if( dy>halflen ) dy=len-dy
            dz = abs(rzO(i)-rzO(j))
            if( dz>halflen ) dz=len-dz
            ibin = int(sqrt(dx**2 + dy**2 + dz**2)/h) +1
            bin(ibin) = bin(ibin)+1
          end if
        end do
      end do
    end if

  end do ! mcstep

  close(43) ! internal energy
  call print_final_positions
  call rdf_print

contains
  subroutine print_final_positions
    implicit none
    open(38,file="positions_final.dat")
    write(38,*) 3*N ! N, which is an integer parameter that should not be read
    write(38,*)"final configuration. Box length is",len
    do i=1,N ! 3 sites per molecule
      write(38,*)"O",rxO(i),ryO(i),rzO(i)
      write(38,*)"H",[rxO(i),ryO(i),rzO(i)]+[rxH1(i),ryH1(i),rzH1(i)]
      write(38,*)"H",[rxO(i),ryO(i),rzO(i)]+[rxH2(i),ryH2(i),rzH2(i)]
    end do
    close(38)
    print*,"positions_final.dat written"
  end subroutine print_final_positions

  ! Generate random quaternion
  ! Method by G. Marsaglia, Choosing a point from the surface of a sphere, Ann. Math. Stat. 43, 645–646 (1972).
  subroutine generate_random_quaternion (q0, q1, q2, q3)
    implicit none
    double precision, intent(out) :: q0, q1, q2, q3
    double precision :: x1, x2, y1, y2, s1, s2, t
    s1=10
    do while(s1>1)
      call random_number(x1)
      call random_number(y1)
      s1=x1**2+y1**2
    end do
    s2=10
    do while(s2>1)
      call random_number(x2)
      call random_number(y2)
      s2=x2**2+y2**2
    end do
    q0=x1
    q1=y1
    t=sqrt((1-s1)/s2)
    q2=x2*t
    q3=y2*t
  end subroutine generate_random_quaternion

  ! if file positions_init.dat exists, then read positions from this file.
  ! else, start with cubic lattice
  subroutine positions_init
    implicit none
    double precision :: dl
    logical :: file_exists
    integer :: i,j,k,l
    character(len=1) :: string
    inquire(file="positions_init.dat", EXIST=file_exists)
    if( file_exists ) then
      open(38,file="positions_init.dat")
      read(38,*)i ! N, which is an integer parameter that should not be read
      read(38,*)string
      do i=1,N ! 3 sites per molecule
        read(38,*)string,rxO(i),ryO(i),rzO(i)
        read(38,*)string,rxH1(i),ryH1(i),rzH1(i)
        rxH1(i) = rxH1(i)-rxO(i)
        ryH1(i) = ryH1(i)-ryO(i)
        rzH1(i) = rzH1(i)-rzO(i)
        read(38,*)string,rxH2(i),ryH2(i),rzH2(i)
        rxH2(i) = rxH2(i)-rxO(i)
        ryH2(i) = ryH2(i)-ryO(i)
        rzH2(i) = rzH2(i)-rzO(i)
      end do
      close(38)
    else
      ! init positions the farther possible in cubic lattice
      l=0
      dl = len/real(nint(N**(1./3.))+1)
      do i=1,nint(N**(1./3.))+1
        do j=1,nint(N**(1./3.))+1
          do k=1,nint(N**(1./3.))+1
            l=l+1
            if (l>N) exit
            rxO(l)=(i-1)*dl
            ryO(l)=(j-1)*dl
            rzO(l)=(k-1)*dl
            if( any([rxO(l),ryO(l),rzO(l)] <0) .or. any([rxO(l),ryO(l),rzO(l)] >=len)) stop "rxinew etc must be >=0 and <len"
          end do
        end do
      end do
      ! init position of hydrogen atoms
      do i=1,N
        rxH1(i) = rH1_molecularframe(1)
        ryH1(i) = rH1_molecularframe(2)
        rzH1(i) = rH1_molecularframe(3)
        rxH2(i) = rH2_molecularframe(1)
        ryH2(i) = rH2_molecularframe(2)
        rzH2(i) = rH2_molecularframe(3)
      end do
    end if

    ! print initial positions
    open(38,file="positions_init.dat")
    write(38,*)3*N ! number of molecules
    write(38,*)len
    do i=1,N ! 3 sites per molecule
      write(38,*)"O",rxO(i),ryO(i),rzO(i)
      write(38,*)"H",[rxO(i),ryO(i),rzO(i)]+[rxH1(i),ryH1(i),rzH1(i)]
      write(38,*)"H",[rxO(i),ryO(i),rzO(i)]+[rxH2(i),ryH2(i),rzH2(i)]
    end do
    close(38)
  end subroutine positions_init

  ! print radial distribution function
  ! ==================================
  subroutine rdf_print
    implicit none
    double precision :: const, rupper, rlower, rho, nideal, gr(size(bin)), grsm(size(bin))
    integer :: imax
    rho = real(N)/len**3
    const = 4.*pi*rho/3.
    open(77,file="rdf.dat")
    imax=0
    do i=1,size(bin)
      r = (i-0.5)*h
      if( r > len/2.) cycle
      if(imax<i) imax=i
      rlower = real(i-1)*h
      rupper = rlower+h
      nideal = const *(rupper**3-rlower**3)
      gr(i) = real(bin(i)) / real(ntrial) / real(N) / nideal
      write(77,*) r, gr(i)
    end do
    close(77)
    ! write a smoothed g(r) see Tildesley p.204
    ! third degree, five point smoothing
    do i=1,imax
      if(i==1) then
        grsm(i)=(69*gr(i)+4* gr(i+1)-6*gr(i+2)+4*gr(i+3)-gr(i+4))/70.
      else if(i==2) then
        grsm(i)=(2* gr(i-1)+27*gr(i)+12*gr(i+1)-8*gr(i+2)+2*gr(i+3))/35.
      else if(i>2 .and. i<imax-1) then
        grsm(i)=(-3*gr(i-2)+12*gr(i-1)+17*gr(i)+12*gr(i+1)-3*gr(i+2))/35.
      else if(i==imax-1) then
        grsm(i)=(2* gr(i+1)+27*gr(i)+12*gr(i-1)-8*gr(i-2)+2*gr(i-3))/35.
      else if(i==imax) then
        grsm(i)=(69*gr(i)+4*gr(i-1)-6*gr(i-2)+4*gr(i-3)-gr(i-4))/70.
      end if
    end do
    open(78,file="smoothed-rdf.dat")
    do i=1,imax
      r=(i-0.5)*h
      write(78,*)r,grsm(i)
    end do
    close(78)
  end subroutine rdf_print

  subroutine fill_q
    implicit none
    integer :: i, j
    j=0
    do i=1,N
      j=j+1
      q(j)=qO
      j=j+1
      q(j)=qH
      j=j+1
      q(j)=qH
    end do
  end subroutine fill_q

  subroutine fill_positions
    implicit none
    integer :: i,j
    j=0
    do i=1,N
      j=j+1
      rx(j)=rxO(i)
      ry(j)=ryO(i)
      rz(j)=rzO(i)
      j=j+1
      rx(j)=rxO(i)+rxH1(i)
      ry(j)=ryO(i)+ryH1(i)
      rz(j)=rzO(i)+rzH1(i)
      j=j+1
      rx(j)=rxO(i)+rxH2(i)
      ry(j)=ryO(i)+ryH2(i)
      rz(j)=rzO(i)+rzH2(i)
    end do
  end subroutine fill_positions

end program lasvegas