MODULE Ptsoilmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_ptsoil(evapoTranspirationPriestlyTaylor, &
        Alpha, &
        tau, &
        tauAlpha, &
        energyLimitedEvaporation)
        IMPLICIT NONE
        REAL, INTENT(IN) :: evapoTranspirationPriestlyTaylor
        REAL, INTENT(IN) :: Alpha
        REAL, INTENT(IN) :: tau
        REAL, INTENT(IN) :: tauAlpha
        REAL, INTENT(OUT) :: energyLimitedEvaporation
        REAL:: AlphaE
        !- Name: PtSoil -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: PtSoil EnergyLimitedEvaporation Model
    !            * Author: Pierre Martre
    !            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    !            Evapotranspiration and canopy and soil temperature calculations
    !            * Institution: INRA Montpellier
    !            * ExtendedDescription: Evaporation from the soil in the energy-limited stage
    !            * ShortDescription: Evaporation from the soil in the energy-limited stage
        !- inputs:
    !            * name: evapoTranspirationPriestlyTaylor
    !                          ** description : evapoTranspiration Priestly Taylor
    !                          ** variablecategory : rate
    !                          ** datatype : DOUBLE
    !                          ** default : 120
    !                          ** min : 0
    !                          ** max : 1000
    !                          ** unit : g m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !            * name: Alpha
    !                          ** description : Priestley-Taylor evapotranspiration proportionality constant
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 1.5
    !                          ** min : 0
    !                          ** max : 100
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: tau
    !                          ** description : plant cover factor
    !                          ** parametercategory : species
    !                          ** datatype : DOUBLE
    !                          ** default : 0.9983
    !                          ** min : 0
    !                          ** max : 100
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: tauAlpha
    !                          ** description : Fraction of the total net radiation exchanged at the soil surface when AlpaE = 1
    !                          ** parametercategory : soil
    !                          ** datatype : DOUBLE
    !                          ** default : 0.3
    !                          ** min : 0
    !                          ** max : 1
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
        !- outputs:
    !            * name: energyLimitedEvaporation
    !                          ** description : energy Limited Evaporation
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 5000
    !                          ** unit : g m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        IF(tau .LT. tauAlpha) THEN
            AlphaE = 1.0
        ELSE
            AlphaE = Alpha - ((Alpha - 1.0) * (1.0 - tau) / (1.0 - tauAlpha))
        END IF
        energyLimitedEvaporation = evapoTranspirationPriestlyTaylor / Alpha *  &
                AlphaE * tau
    END SUBROUTINE model_ptsoil

END MODULE


      SUBROUTINE JULDAY(IYEAR,MONTH,IDAY,XJD)
      IMPLICIT REAL*8 (A-H,O-Z)
C CONVERTS CALENDAR DATE INTO JULIAN DATE
      DIMENSION IMON(12)
C
C
      DATA IMON/0,31,28,31,30,31,30,31,31,30,31,30/
C
      NYEAR=IYEAR-1961
      NLEAP=NYEAR/4
      NYRDAY=NYEAR*365+NLEAP
C
C
      MODAY=0
      IF (MONTH.GT.2.AND.NYEAR-4*NLEAP.EQ.3) MODAY=1
      DO 10 I=1,MONTH
   10 MODAY=MODAY+IMON(I)
C
C JULIAN BASE DATE IS DEC 31,1960 = 2437299.5 (A.M. MIDNIGHT)
      XJD=NYRDAY+MODAY+IDAY+2437299.5D0
C
      RETURN
      ENTRY CALDAY(XJD,IYEAR,MONTH,IDAY,UT)
      XDAY=XJD-2437300.5D0
      IDAY=XDAY
      UT=(XDAY-IDAY)*86400.D0
      NYEAR=XDAY/365.25D0
      NLEAP=NYEAR/4
      ILEAP=NYEAR-4*NLEAP
      NYRDAY=IDAY+1-365*NYEAR-NLEAP
      IDAY=NYRDAY
      DO 20 I=2,12
      MONTH=I-1
      MODAY=IMON(I)
      IF (MONTH.EQ.2.AND.ILEAP.EQ.3) MODAY=MODAY+1
      IF (IDAY.LE.MODAY) GO TO 22
      IDAY=IDAY-MODAY
   20 CONTINUE
      MONTH=12
      IF (IDAY.LT.32) GO TO 22
      IDAY=1
      MONTH=1
      NYEAR=NYEAR+1
   22 IYEAR=NYEAR+1961
      RETURN
      END


! (C) Copyright 2019 UCAR and 2011-2018 John Thuburn, University of Exeter, UK
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.

program fempoisson_driver

use femps_kinds_mod
use femps_grid_mod
use femps_operators_mod
use femps_testgrid_mod
use femps_solve_mod
use femps_fv3_mod

implicit none
type(fempsgrid) :: grid_fem, grid_fv3
type(fempsoprs) :: oprs_fem, oprs_fv3

type testdata
  real(kind=kind_real), allocatable, dimension(:) :: zeta, psi0, psi
end type testdata

real(kind=kind_real) :: rms_fem, rms_fv3, rms_ref, rms_rel, tol

type(testdata) :: test_fem
type(testdata) :: test_fv3

! Create the FEMPS test grid
! --------------------------
call grid_fem%setup('cs',ngrids=6,cube=96,niter=10)
call cstestgrid(grid_fem)

! Create the FV3 test grid
! ------------------------
call grid_fv3%setup('cs',ngrids=5,cube=96,niter=50)
call fv3grid_to_ugrid(grid_fv3,'Data/')

! Build the connectivity and extra geom
! -------------------------------------
call grid_fem%build_cs(1,1)
call grid_fv3%build_cs(1,1)

! Write grids
! -----------
call grid_fem%writegrid('grid_fem.nc4')
call grid_fv3%writegrid('grid_fv3.nc4')

! Perform all the setup
! ---------------------
call preliminary(grid_fem,oprs_fem)
call preliminary(grid_fv3,oprs_fv3)

call oprs_fem%pdelete() !Partial deletes
call oprs_fv3%pdelete() !Partial deletes

call oprs_fem%writeoperators(grid_fem,'operators_fem.nc4')
call oprs_fv3%writeoperators(grid_fv3,'operators_fv3.nc4')

! Set up test data
! ----------------
call test_setup(test_fem,grid_fem)
call test_setup(test_fv3,grid_fv3)

! Laplacian
! ---------
call laplace(grid_fem,oprs_fem,grid_fem%ngrids,test_fem%psi0,test_fem%zeta)
call laplace(grid_fv3,oprs_fv3,grid_fv3%ngrids,test_fv3%psi0,test_fv3%zeta)

! Inverse Laplacian
! -----------------
call inverselaplace(grid_fem,oprs_fem,grid_fem%ngrids,test_fem%zeta,test_fem%psi,.true.)
call inverselaplace(grid_fv3,oprs_fv3,grid_fv3%ngrids,test_fv3%zeta,test_fv3%psi,.true.)

! Print output
! ------------
call test_endloop(test_fem,grid_fem,rms_fem)
call test_endloop(test_fv3,grid_fv3,rms_fv3)

! Test pass/fail - femps
! --------------
tol = 1.0e-11_kind_real

rms_ref = 5.632313769573670E-004_kind_real
rms_rel = abs((rms_fem - rms_ref)/rms_ref)

print*, ' '
print*, ' '
print*, 'Result for femps internal grid'
print*, 'Expected RMS', rms_ref
print*, 'Actual RMS', rms_fem
print*, 'Relative difference', rms_rel

if (abs(rms_rel) > tol) then
  print*, ' '
  print*, 'Test failed with requirement that relative difference to expected RMS <=',tol
  print*, ' '
  stop 1
else
  print*, ' '
  print*, 'Test passed'
  print*, ' '
endif

! Test pass/fail - fv3
! --------------
rms_ref = 6.481994273258480E-005_kind_real
rms_rel = abs((rms_fv3 - rms_ref)/rms_ref)

print*, 'Result for fv3 grid'
print*, 'Expected RMS', rms_ref
print*, 'Actual RMS', rms_fv3
print*, 'Relative difference', rms_rel

if (abs(rms_rel) > tol) then
  print*, ' '
  print*, 'Test failed with requirement that relative difference to expected RMS <=',tol
  print*, ' '
  stop 1
else
  print*, ' '
  print*, 'Test passed'
  print*, ' '
endif

! Clean up
! --------
call oprs_fem%delete()
call grid_fem%delete()
call oprs_fv3%delete()
call grid_fv3%delete()

call test_delete(test_fem)
call test_delete(test_fv3)

stop 0

! --------------------------------------------------------------------------------------------------

contains

! --------------------------------------------------------------------------------------------------

subroutine test_setup(test,grid)

implicit none

type(testdata),  intent(inout) :: test
type(fempsgrid), intent(in)    :: grid

integer :: n
real(kind=kind_real) :: psibar

allocate(test%zeta(grid%nface(grid%ngrids)))
allocate(test%psi0(grid%nface(grid%ngrids)))
allocate(test%psi (grid%nface(grid%ngrids)))

do n = 1, grid%nface(grid%ngrids)
 test%psi0(n) = cos(grid%flat(n,grid%ngrids))*sin(grid%flong(n,grid%ngrids)) ! Large-scale part
enddo
test%psi0(10) = 10.0_kind_real*test%psi0(10) ! Plus small-scale part

! Remove global mean (to ensure unambiguous result)
psibar = sum(test%psi0*grid%farea(:,grid%ngrids))/sum(grid%farea(:,grid%ngrids))
test%psi0 = test%psi0 - psibar

! Convert to area integrals
test%psi0 = test%psi0*grid%farea(:,grid%ngrids)

end subroutine test_setup

! --------------------------------------------------------------------------------------------------

subroutine test_delete(test)

implicit none

type(testdata), intent(inout) :: test

deallocate(test%zeta, test%psi0, test%psi)

end subroutine test_delete

! --------------------------------------------------------------------------------------------------

subroutine test_endloop(test,grid,rms)

implicit none

type(testdata),       intent(inout) :: test
type(fempsgrid),      intent(in)    :: grid
real(kind=kind_real), intent(out)   :: rms

integer :: n, nprt = 5

print *,' '
do n = 1,nprt
 print *,'Original field psi0     = ', test%psi0(n)
 print *,'Soln of Poisson eqn psi = ', test%psi(n)
enddo
test%psi0 = test%psi0/grid%farea(:,grid%ngrids)
test%psi  = test%psi/grid%farea(:,grid%ngrids)
print *,' '

rms = sqrt(sum((test%psi0-test%psi)*(test%psi0-test%psi))/grid%nface(grid%ngrids))
print *,'RMS err in global problem = ', rms

end subroutine test_endloop

! --------------------------------------------------------------------------------------------------

end program fempoisson_driver


module mod_hash_map
  implicit none
  integer, parameter :: int_max_value = 2147483647
  integer, parameter :: default_initial_capacity = 16
  integer, parameter :: maximum_capacity = lshift(1, 30)
  real, parameter :: default_load_factor = 0.75

  type t_entry
    integer :: key
    integer :: val
    type(t_entry), pointer :: next => null()
    integer :: hash
  end type

  type t_entry_ptr
    type(t_entry), pointer :: ref => null()
  end type

  type t_hash_map
    type(t_entry_ptr), private, allocatable :: table(:)
    integer :: size = 0
    integer, private :: threshold = int(default_initial_capacity * default_load_factor)
    real, private :: load_factor = default_load_factor
  contains
    procedure :: is_empty => is_empty
    procedure :: is_not_empty => is_not_empty
    procedure :: put => put
    procedure :: get => get
    procedure :: get_or_default => get_or_default
    procedure :: remove => remove
    procedure :: clear => clear
    procedure :: contains_key => contains_key
    procedure :: contains_val => contains_val
  end type

  interface hash_map
    module procedure :: newhm0, newhm1, newhm2
  end interface

contains

  function new_entry(key, val, h) result(res)
    integer, intent(in) :: key
    integer, intent(in) :: val
    integer, intent(in) :: h
    type(t_entry), pointer :: res
    allocate(res)
    res%key = key
    res%val = val
    res%hash = h
  end

  integer function hash_code(i) result(res)
    integer, intent(in) :: i
    res = i
  end

  type(t_hash_map) function newhm0() result(res)
    allocate(res%table(default_initial_capacity))
  end

  type(t_hash_map) function newhm1(initial_capacity) result(res)
    integer, intent(in) :: initial_capacity
    res = newhm2(initial_capacity, default_load_factor)
  end

  type(t_hash_map) function newhm2(initial_capacity, load_factor) result(res)
    integer, intent(in) :: initial_capacity
    real, intent(in) :: load_factor
    integer :: capacity
    if (initial_capacity < 0) then
      capacity = default_initial_capacity
    else
      capacity = 1
      do while (capacity < min(initial_capacity, maximum_capacity))
        capacity = lshift(capacity, 1)
      end do
    end if

    if (load_factor <= 0 .or. load_factor /= load_factor) then
      res%load_factor = default_load_factor
    else
      res%load_factor = load_factor
    end if

    res%threshold = int(capacity * res%load_factor)
    allocate(res%table(capacity))
  end

  integer function shr(i, n) result(res)
    integer, intent(in) :: i, n
    if (n == 0) then
      res = i
    else
      res = rshift(ibclr(rshift(i, 1), 31), n-1)
    end if
  end

  integer function hash(i) result(res)
    integer, intent(in) :: i
    integer :: h
    h = i
    h = xor(h, xor(shr(h, 20), shr(h, 12)))
    res = xor(h, xor(shr(h, 7), shr(h, 4)))
  end

  integer function index_for(h, length) result(res)
    integer, intent(in) :: h, length
    res = and(h, length - 1) + 1
  end

  logical function is_empty(this) result(res)
    class(t_hash_map), intent(in) :: this
    res = this%size == 0
  end

  logical function is_not_empty(this) result(res)
    class(t_hash_map), intent(in) :: this
    res = this%size /= 0
  end

  integer function get(this, key) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: key
    integer :: h
    type(t_entry), pointer :: e
    h = hash(hash_code(key))
    e => this%table(index_for(h, size(this%table)))%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) then
        res = e%val
        return
      end if
      e => e%next
    end do
    res = 0
  end

  integer function get_or_default(this, key, def) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: key
    integer, intent(in) :: def
    integer :: h
    type(t_entry), pointer :: e
    h = hash(hash_code(key))
    e => this%table(index_for(h, size(this%table)))%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) then
        res = e%val
        return
      end if
      e => e%next
    end do
    res = def
  end

  logical function contains_key(this, key) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: key
    type(t_entry), pointer :: e
    e => get_entry(this, key)
    res = associated(e)
  end

  function get_entry(this, key) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: key
    integer :: h
    type(t_entry), pointer :: e
    type(t_entry), pointer :: res
    h = hash(hash_code(key))
    e => this%table(index_for(h, size(this%table)))%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) then
        res => e
        return
      end if
      e => e%next
    end do
    res => null()
  end

  subroutine put(this, key, val)
    class(t_hash_map), intent(inout) :: this
    integer, intent(in) :: key
    integer, intent(in) :: val
    integer :: h, i
    type(t_entry), pointer :: e
    h = hash(hash_code(key))
    i = index_for(h, size(this%table))
    e => this%table(i)%ref
    do while (associated(e))
      if (e%hash == h .and. e%key == key) then
        e%val = val
        return
      end if
      e => e%next
    end do
    call add_entry(this, key, val, h, i)
  end

  subroutine add_entry(this, key, val, h, idx)
    class(t_hash_map), intent(inout) :: this
    integer, intent(in) :: key
    integer, intent(in) :: val
    integer, intent(in) :: h, idx
    type(t_entry), pointer :: e
    e => this%table(idx)%ref
    this%table(idx)%ref => new_entry(key, val, h)
    this%table(idx)%ref%next => e
    this%size = this%size + 1
    if (this%size >= this%threshold) call resize(this, 2 * size(this%table))
  end

  subroutine resize(this, new_capacity)
    class(t_hash_map), intent(inout) :: this
    integer, intent(in) :: new_capacity
    integer :: capacity, i, j
    type(t_entry), pointer :: e, next
    type(t_entry_ptr) :: table(new_capacity)
    capacity = size(this%table)
    if (capacity == maximum_capacity) then
      this%threshold = int_max_value
      return
    end if

    do j = 1, capacity
      e => this%table(j)%ref
      if (associated(e)) then
        this%table(j)%ref => null()
        do
          next => e%next
          i = index_for(e%hash, new_capacity)
          e%next => table(i)%ref
          table(i)%ref => e
          e => next
          if (.not.associated(e)) exit
        end do
      end if
    end do

    deallocate(this%table)
    allocate(this%table(new_capacity))
    do j = 1, new_capacity
      this%table(j)%ref => table(j)%ref
    end do
    this%threshold = int(new_capacity * this%load_factor)
  end

  subroutine remove(this, key)
    class(t_hash_map), intent(inout) :: this
    integer, intent(in) :: key
    integer :: h, i
    type(t_entry), pointer :: e, prev, next
    h = hash(hash_code(key))
    i = index_for(h, size(this%table))
    prev => this%table(i)%ref
    e => prev
    do while (associated(e))
      next => e%next
      if (e%hash == h .and. e%key == key) then
        this%size = this%size - 1
        if (associated(prev, e)) then
          this%table(i)%ref => next
        else
          prev%next => next
        end if
        return
      end if
      prev => e
      e => next
    end do
  end

  subroutine clear(this)
    class(t_hash_map), intent(inout) :: this
    deallocate(this%table)
    allocate(this%table(default_initial_capacity))
    this%size = 0
  end

  logical function contains_val(this, val) result(res)
    class(t_hash_map), intent(in) :: this
    integer, intent(in) :: val
    integer :: i
    type(t_entry), pointer :: e
    do i = 1, size(this%table)
      e => this%table(i)%ref
      do while (associated(e))
        if (e%val == val) then
          res = .true.
          return
        end if
        e => e%next
      end do
    end do
    res = .false.
  end
end module mod_hash_map


!---------------------------------------------------------------------------------
!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 !Sum of thes values = 1
	real::probpos !Probability of picking a positive spin
	real::extMagField
	integer(kind=int64):: MCS, EquilSteps!, NumofTempPoints
	integer(kind=int64):: i!,indexTemp !Dummy indeces
	integer::k,printOPT,spinDyn
	integer :: index1, index2
	integer::exchangeSpin
	integer,allocatable::matriz(:,:)
	integer,allocatable::ip(:),im(:)
	integer::promediateCounter
	integer::IDfile1,IDfile2
	real,allocatable::alpha(:,:)
	real::alpha11,alpha13,alpha33
	integer(dp),allocatable::InterPos(:),InterNeg(:),InterPN(:)
	!Type interaction v2:  4N values
	integer(dp),allocatable::InterPos2(:),InterNeg2(:),InterPN2(:)
	!integer::interPos,interNeg,interPN
	!real,allocatable::rIdeal(:),rMeasured(:),rho(:)
	!real::rIdeal,rMeasured,rho
	real::Delta_E
	real::rvec(1)
	real(dp),allocatable::Magnetization(:), Magnetization2(:),Magnetization4(:),Energy(:),Energy2(:)
	real(dp),dimension(20)::DeltaE
	real::currentTemp,beta
	character(len=100)::MagFile ='Magnetization20L.dat', EnergFile = 'Energy20L.dat'
	character(len=100)::InterFile='Inter20L.dat',InterFile2='Inter220L.dat'

	! 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,*) 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,*) 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))

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

	allocate(InterPN(npoints))
	allocate(InterPos(npoints))
	allocate(InterNeg(npoints))

	!Allocate interaction arrays v2
	allocate(InterPN2(npoints))
	allocate(InterPos2(npoints))
	allocate(InterNeg2(npoints))

	!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

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

	if ( EquilSteps >= MCS ) then
		STOP 'Change the value of EquilSteps in the Configuration File! It can not be greater than MCS'
	end if

	!1MCS = dim = nrows*ncols = 400
	! 10 000 MCS = 4M
	print *, "MCS = ",MCS, " EquilSteps = ", EquilSteps

	!If the file exists overwrite erase it.
	!FileIDs
	IDfile1 = 34
	IDfile2 = 35
	open (UNIT=1, FILE=MagFile,ACTION='write',STATUS='replace')
	write(1,*) "Tiempo AverMagnetization AverMagnetization^2 Suceptibility Cumulant"
	open (UNIT=33, FILE=EnergFile,ACTION='write',STATUS='replace')
	write(33,*) "Tiempo AverEnergy AverEnergy^2 C_v"
	open (UNIT=IDfile1, FILE=InterFile,ACTION='write',STATUS='replace')
	write(IDfile1,*) "Tiempo InterPos InterNeg InterPN IdealR MeasuredR Rho"
	open (UNIT=IDfile2, FILE=InterFile2,ACTION='write',STATUS='replace')
	write(IDfile2,*) "Tiempo InterPos2 InterNeg2 InterPN2"

	call ini_alpha(alpha,alpha11,alpha13,alpha33)

	beta = 1.0/currentTemp
	print *, "Current Temperature T = ", currentTemp,"beta = ",beta
	!print *, 'npoints: ',npoints
	!Initialize some variables to zero
	call SetToZeroVariables(Magnetization,Magnetization2, &
								Magnetization4,Energy,Energy2,npoints)

	!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)
		!Write initial spin configurations in screen for DynamicLattice
		if(printOPT == 1) then
			call WriteSpinConf(matriz,nrows,ncols)
		end if
		!call CountPosNeg(matriz,nrows,ncols,npos,nneg)

		print *, "Average loop k = ", k,"/",average
		promediateCounter = 0
		!Choose a 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,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*dim

			!Calculate the Magnetization and Energy after equilibrium
			if ( i > EquilSteps*dim .AND. mod(i,(MCS-EquilSteps)*dim/npoints) == 0 ) 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)

				call CellInteraction(matriz,nrows,ncols,ip,im,npos,k,&
					interPos(promediateCounter),interNeg(promediateCounter),interPN(promediateCounter))

				call CellInteractionV2(matriz,nrows,ncols,ip,im,npos,k,&
					interPos2(promediateCounter),interNeg2(promediateCounter),interPN2(promediateCounter))
				!call WriteSpinConf(matriz,nrows,ncols)
			end if
			!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
				!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
				if (Delta_E <= 0) then
					call exchange(nrows,ncols,posx,posy,matriz,ip,newposx,newposy)
					!print*,"Fue menor a cero"
				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)
						end if
					else
						if ( rvec(1) < exp(-Delta_E/currentTemp) ) then
							call exchange(nrows,ncols,posx,posy,matriz,ip,newposx,newposy)
						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,matriz,k)
			end if

			!----------------------------------------------------------------
			!-----PRINT SITES IN DYNAMIC LATTICE ----------------------------
			if(printOPT == 2) then
				do index1=1,nrows
					do index2=1,ncols
						write(*,*) index1,index2,matriz(index1,index2)
					end do
				end do
			end if
			!----------------------------------------------------------------
		end do !End loop of the MC steps
	end do ! End loop of averages

	!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,npoints)
	call WriteInteractions(IDfile1,interPos,interNeg,interPN,npos,nrows,ncols,npoints)

	!Write the results of interactions v2 in a file
	call WriteInteractions(IDfile2,interPos2,interNeg2,interPN2,npos,nrows,ncols,npoints)

	!Write final spin configurations in screen for DynamicLattice
	if(printOPT == 1) then
		call WriteSpinConf(matriz,nrows,ncols)
	end if

	close(1)
	close(33)
	close(34)
end program kawasaki


use FEMDomainClass
implicit none

type(FEMDomain_),target :: cube
type(IO_) :: f
real(real64),allocatable :: GlobalVector(:),ElementVector(:)

! create Domain
call cube%create(meshtype="Cube3D",x_num=5,y_num=10,z_num=5)
! test code for GlobalVector
ElementVector = arange( cube%nne()*cube%nd() )
call cube%GlobalVector(&
    ElementID=10, &
    ElementVector=ElementVector, &
    GlobalVector=GlobalVector, &
    DOF=cube%nd() )
ElementVector = arange( cube%nne()*cube%nd() )
call cube%GlobalVector(&
    ElementID=22, &
    ElementVector=ElementVector, &
    GlobalVector=GlobalVector, &
    DOF=cube%nd() )
!call print(reshape(ElementVector,cube%nne(),cube%nd() ) )
!stop

call print("Element #10 consists of Nodes ID")
call print( cube%connectivity(10) )

call print("Element #22 consists of Nodes ID")
call print( cube%connectivity(22) )

call f%open("GlobalVector.txt")
call f%write(reshape(GlobalVector,cube%nn(),cube%nd() ) )
call f%close()

end


module modmyprecond
 use iso_fortran_env
 !$ use omp_lib
#if (COARRAY==1)
 use modprecond,only:gen_precond
#endif
 implicit none
 private
 public::arrayprecond

#if (COARRAY==1)
 type,extends(gen_precond)::arrayprecond
#else
 type::arrayprecond
#endif
  integer(kind=int32)::dim1
  real(kind=real64),allocatable::array(:)
 contains
  procedure,public::solve
 end type

contains

!SOLVE
subroutine solve(this,x,y)
 !solve this*x=y, by doing x=inv(this)*y
 class(arrayprecond),intent(inout)::this
 real(kind=real64),intent(out)::x(:)
 real(kind=real64),intent(inout)::y(:)

 integer(kind=int32)::i
 logical,save::lnotinverse=.true.

 if(lnotinverse)then
  do i=1,this%dim1
   if(this%array(i).ne.0_real64)this%array(i)=1._real64/this%array(i)
  enddo
  lnotinverse=.false.
 endif

 do i=1,this%dim1
  x(i)=this%array(i)*y(i)
 enddo

end subroutine

end module


!*****************************************************************************
!
! Rokko: Integrated Interface for libraries of eigenvalue decomposition
!
! Copyright (C) 2012-2019 by Rokko Developers https://github.com/t-sakashita/rokko
!
! Distributed under the Boost Software License, Version 1.0. (See accompanying
! file LICENSE_1_0.txt or copy at http://www.boost.org/license_1_0.txt)
!
!*****************************************************************************

program minij_matrix
  use rokko
  implicit none
  integer :: dim
  type(rokko_serial_dense_ev) :: solver
  type(rokko_eigen_matrix) :: mat, Z
  type(rokko_eigen_vector) :: diag, w
  type(rokko_parameters) :: params, params_out
  character(len=:), allocatable :: library, routine
  character(len=:), allocatable :: solver_name, tmp_str
  double precision, pointer, dimension(:) :: diag_ptr
  integer :: i, info

  if (command_argument_count() >= 1) then
     call get_command_argument_deferred(1, solver_name)
  else
     solver_name = rokko_serial_dense_ev_default_solver()
  endif
  call rokko_split_solver_name(solver_name, library, routine)

  if (command_argument_count() == 2) then
     call get_command_argument_deferred(2, tmp_str)
     read(tmp_str, *) dim
  else
     dim = 10
  endif

  print *,"library = ", library
  print *,"routine = ", routine
  print *,"dimension = ", dim

  call rokko_construct(solver, library)

  call rokko_construct(mat, dim, dim, rokko_matrix_col_major)
  call rokko_construct(Z, dim, dim, rokko_matrix_col_major)
  call rokko_construct(w, dim)

  ! generate matrix whose eigenvectors are helmert matrix
  call rokko_construct(diag, dim)
  call rokko_get_array_pointer(diag, diag_ptr)
  do i=1, dim
     diag_ptr(i) = i
  enddo
  call rokko_helmert_matrix_generate(mat, diag)
  call rokko_print(mat)

  call rokko_construct(params)
  call rokko_set(params, "routine", "syev")

!  call diagonalize(solver, mat, w, Z, params, params_out)
!  call diagonalize(solver, mat, w, Z, params)
!  call diagonalize(solver, mat, w, Z)
  call rokko_diagonalize(solver, mat, w, params, params_out)
!  call diagonalize(solver, mat, w, params)
!  call diagonalize(solver, mat, w)

  call rokko_get(params_out, "info", info)

  print *, "info=", info

  write(*,'(A)') "Computed Eigenvalues = "
  do i = 1, dim
     write(*,"(f30.20)") rokko_get_elem(w ,i)
  enddo

  call rokko_destruct(mat)
  call rokko_destruct(Z)
  call rokko_destruct(w)
  call rokko_destruct(solver)

end program minij_matrix


module fitutil

character(len=512) :: input_file
character(len=512) :: output_file

integer :: poly_order
double precision :: period(4)
integer :: nperiod
double precision :: exp_const(4)
integer :: nexponent
logical :: doPolynomial
logical :: doSinusoid
logical :: doExponential
logical :: findExpConstant

logical :: labelCoefficients

character(len=512) :: pre_file
logical :: printPredicted

end module

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

program main

#ifdef USE_LAPACK

use io, only: stdin, stdout, stderr, fileExists, line_count
use trig, only: pi
use solver, only: solve_dgels

use fitutil, only: input_file, &
                   output_file, &
                   poly_order, &
                   period, &
                   nperiod, &
                   exp_const, &
                   nexponent, &
                   doPolynomial, &
                   doSinusoid, &
                   doExponential, &
                   findExpConstant, &
                   labelCoefficients, &
                   pre_file, &
                   printPredicted

implicit none

! Local variables
integer :: i, j, ios, ierr, nrows, ncols, ptr_poly, ptr_sin, ptr_exp, npoly, nsin, nexp, luin, luout
integer :: iperiod, iexponent
integer, parameter :: NROWS_STDIN = 100000
character(len=512) :: line
double precision, allocatable :: obs(:,:), A(:,:), b(:), x(:)
double precision :: pre, amp, pha

! Parse command line
call gcmdln()

! Make sure something needs to be fit...
if (.not.doPolynomial .and. .not.doSinusoid .and. .not.doExponential) then
    call usage('fitutil: no fitting function specified')
endif

! Determine input/output streams
if (input_file.eq.''.or.input_file.eq.'none'.or.input_file.eq.'stdin') then
    luin = stdin
else
    if (.not.fileExists(input_file)) then
        call usage('fitutil: no file found named "'//trim(input_file)//'"')
    endif
    luin = 11
endif

if (output_file.eq.''.or.output_file.eq.'none'.or.output_file.eq.'stdout') then
    luout = stdout
else
    luout = 12
    open(unit=luout,file=output_file,status='unknown')
endif

! Calculate number of parameters to fit and set up pointers to array
ncols = 0
ptr_poly = 0
ptr_sin = 0
ptr_exp = 0
npoly = 0
nsin = 0
nexp = 0

if (doPolynomial) then
    ptr_poly = ncols + 1
    npoly = poly_order + 1
    ncols = ncols + npoly
endif

if (doSinusoid) then
    ptr_sin = ncols + 1
    nsin = 2*nperiod
    ncols = ncols + nsin
endif

if (doExponential) then
    ptr_exp = ncols + 1
    if (findExpConstant) then
        if (ptr_exp.gt.1) then
            call usage('fitutil: cannot linearize model matrix with exponential and polynomial '//&
                       'or sinusoid')
        endif
        nexp = 2
    else
        nexp = nexponent
    endif
    ncols = ncols + nexp
endif

! Count number of input values and read into obs array
nrows = 0
if (luin.eq.stdin) then
    allocate(obs(NROWS_STDIN,2))
    do
        read(luin,'(A)',iostat=ios) line
        if (ios.ne.0) then
            exit
        else
            nrows = nrows + 1
            if (nrows.gt.NROWS_STDIN) then
                write(stderr,*) 'fitutil: max number of lines using stdin is ',NROWS_STDIN
                call usage(     'Read input from file to increase number of inputs')
            endif
            read(line,*,iostat=ios) obs(nrows,1),obs(nrows,2)
            if (ios.ne.0) then
                write(stderr,*) 'fitutil: error parsing x-y from line ',nrows
                call usage(     'Offending line: '//trim(line))
            endif
        endif
    enddo

else
    nrows = line_count(input_file)
    open(unit=luin,file=input_file,status='old')
    allocate(obs(nrows,2))
    do i = 1,nrows
        read(luin,'(A)',iostat=ios,err=9001,end=9001) line
        read(line,*,iostat=ios) obs(i,1),obs(i,2)
        9001 if (ios.ne.0) then
            write(stderr,*) 'fitutil: error parsing x-y from line ',i
            call usage(     'Offending line: '//trim(line))
        endif
    enddo
endif

! Load model matrix and data vector

! Allocate memory to model matrix, data vector, and solution vector
allocate(A(nrows,ncols))
allocate(b(nrows))
allocate(x(ncols))

! Load arrays
do i = 1,nrows
    if (doPolynomial) then
        do j = 1,poly_order+1
            A(i,j) = obs(i,1)**(j-1)
        enddo
    endif

    if (doSinusoid) then
        do j = 1,nperiod
            A(i,ptr_sin+2*(j-1)) = sin(2.0d0*pi/period(j)*obs(i,1))
            A(i,ptr_sin+2*(j-1)+1) = cos(2.0d0*pi/period(j)*obs(i,1))
        enddo
    endif

    if (doExponential) then
        if (findExpConstant) then
            A(i,ptr_exp) = obs(i,1)
            A(i,ptr_exp+1) = 1.0d0
        else
            do j = 1,nexponent
                A(i,ptr_exp+j-1) = exp(exp_const(j)*obs(i,1))
            enddo
        endif
    endif

    b(i) = obs(i,2)
enddo

if (doExponential.and.findExpConstant) then
    b = log(b)
endif

! Solve system of equations Ax = b for x
call solve_dgels(A,b,x,nrows,ncols,ierr)

! Write results to file or standard output
i = 1
do while (i.le.ncols)
    ! Polynomial
    if (i.le.ptr_poly+npoly-1) then
        if (labelCoefficients) then
            write(luout,'(" Order_",I0.2,X,1PE16.8)') i-1,x(i)
        else
            write(luout,*) x(i)
        endif

    ! Sinusoid
    elseif (i.le.ptr_sin+nsin-1) then
        amp = sqrt(x(i)**2+x(i+1)**2)
        pha = atan2(x(i+1),x(i))
        if (labelCoefficients) then
            write(luout,'(" SinAmplitude_",I0.2,X,1PE16.8)') i-ptr_sin+1,amp
            write(luout,'(" SinPhase_",I0.2,X,1PE16.8)') i-ptr_sin+1,pha
        else
            write(luout,*) amp
            write(luout,*) pha
        endif
        i = i + 1

    ! Exponential
    elseif (i.le.ptr_exp+nexp-1) then
        if (findExpConstant) then
            if (labelCoefficients) then
                write(luout,'(" ExpAmplitude_",I0.2,X,1PE16.8)') i,exp(x(i+1))
                write(luout,'(" ExpConst_",I0.2,X,1PE16.8)') i,x(i)
            else
                write(luout,*) exp(x(i+1))
                write(luout,*) x(i)
            endif
            i = i + 1
        else
            if (labelCoefficients) then
                write(luout,'( " ExpAmplitude_",I0.2,X,1PE16.8)') i-ptr_exp+1,x(i)
            else
                write(luout,*) x(i)
            endif
        endif
    endif
    i = i + 1
enddo

! Print predicted results
if (printPredicted) then
    open(unit=31,file=pre_file,status='unknown')
    do i = 1,nrows
        pre = 0.0d0
        j = 1
        do while (j.le.ncols)
            ! Polynomial
            if (j.le.ptr_poly+npoly-1) then
                pre = pre + x(j)*obs(i,1)**(j-1)

            ! Sinusoid
            elseif (j.le.ptr_sin+nsin-1) then
                iperiod = (j-ptr_sin)/nsin + 1
                amp = sqrt(x(j)**2+x(j+1)**2)
                pha = atan2(x(j+1),x(j))
                pre = pre + amp*sin(2.0d0*pi/period(iperiod)*obs(i,1)+pha)
                j = j + 1

            ! Exponential
            elseif (j.le.ptr_exp+nexp-1) then
                if (findExpConstant) then
                    pre = pre + exp(x(i+1))*exp(x(i)*obs(i,1))
                    j = j + 1
                else
                    iexponent = (j-ptr_exp)/nexponent+1
                    pre = pre + x(j)*exp(exp_const(iexponent)*obs(i,1))
                endif
            endif
            j = j + 1
        enddo
        write(31,*) pre
    enddo
    close(31)
endif

if (luin.ne.stdin) then
    close(11)
endif
if (luout.ne.stdout) then
    close(12)
endif

#else
    call usage('fitutil: does not work if compiled without LAPACK libraries')
#endif

end

!--------------------------------------------------------------------------------------------------!

subroutine gcmdln()

use fitutil, only: input_file, &
                   output_file, &
                   poly_order, &
                   period, &
                   nperiod, &
                   exp_const, &
                   nexponent, &
                   doPolynomial, &
                   doSinusoid, &
                   doExponential, &
                   findExpConstant, &
                   labelCoefficients, &
                   pre_file, &
                   printPredicted

implicit none

! Local variables
integer :: i, ios, narg
character(len=512) :: tag
double precision :: dp

input_file = ''
output_file = ''
poly_order = 0
period = 0.0d0
nperiod = 0
exp_const = 0.0d0
nexponent = 0
doPolynomial = .false.
doSinusoid = .false.
doExponential = .false.
findExpConstant = .false.
labelCoefficients = .true.
pre_file = ''
printPredicted = .false.

! Number of arguments
narg = command_argument_count()
if (narg.eq.0) then
  call usage('')
endif

! Read arguments
i = 1
do while (i.le.narg)

    call get_command_argument(i,tag)

    if (trim(tag).eq.'-f') then
        i = i + 1
        call get_command_argument(i,input_file)

    elseif (tag.eq.'-o') then
        i = i + 1
        call get_command_argument(i,output_file)

    elseif (tag.eq.'-poly') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) poly_order
        doPolynomial = .true.

    elseif (tag.eq.'-sin') then
        i = i + 1
        call get_command_argument(i,tag)
        nperiod = nperiod + 1
        if (nperiod.gt.4) then
            call usage('fitutil: maximum number of sinusoidal periods is 4')
        endif
        read(tag,*) period(nperiod)
        doSinusoid = .true.

    elseif (tag.eq.'-exp') then
        ! Default: fit single exponential amplitude and exponential constant to data
        findExpConstant = .true.

        ! Check if the exponential constant is fixed
        i = i + 1
        if (i.le.narg) then
            call get_command_argument(i,tag)
            read(tag,*,iostat=ios) dp
            if (ios.eq.0) then
                ! If this can be read as a real number, then the exponential constant is fixed
                nexponent = nexponent + 1
                if (nexponent.gt.4) then
                    call usage('fitutil: maximum number of exponential constants is 4')
                endif
                read(tag,*,iostat=ios) exp_const(nexponent)
                findExpConstant = .false.
            else
                i = i - 1
            endif
        endif

        doExponential = .true.

    elseif (tag.eq.'-label_coeff') then
        i = i + 1
        call get_command_argument(i,tag)
        if (tag.eq.'Y'.or.tag.eq.'y'.or.tag.eq.'1'.or.tag.eq.'on') then
            labelCoefficients = .true.
        elseif (tag.eq.'N'.or.tag.eq.'n'.or.tag.eq.'0'.or.tag.eq.'off') then
            labelCoefficients = .false.
        endif

    elseif (tag.eq.'-pre') then
        i = i + 1
        call get_command_argument(i,pre_file)
        printPredicted = .true.

    else
        call usage('fitutil: no option '//trim(tag))
    endif

    i = i + 1

enddo

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine usage(str)

use io, only: stderr

implicit none

character(len=*) :: str

if (str.ne.'') then
    write(stderr,*) trim(str)
    write(stderr,*)
endif

write(stderr,*) 'Usage: fitutil ...options...'
write(stderr,*)
write(stderr,*) '-f FILE           X-Y data to fit (default: stdin)'
write(stderr,*) '-o FILE           Inverted coefficients (default: stdout)'
write(stderr,*) '-poly N           Polynomial fit of order N'
write(stderr,*) '-sin T            Sinusoid fit with period T (repeat up to 4 times)'
write(stderr,*) '-exp [TAU]        Exponential fit (optional: up to 4 fixed exponential constants)'
write(stderr,*) '-label_coeff Y|N  Label output coefficients (default: Y)'
write(stderr,*) '-pre PFILE        Predicted values at input x-coordinates'
write(stderr,*)

call error_exit(1)
end subroutine


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   Intrinsics and generics: AIMAG and CONJG.

	program p
	implicit complex (c)
	parameter (n = 17 )
	real rslts(n), expect(n)
	complex crslts(4)
	equivalence (crslts, rslts(10))

	complex ca(3)
	data c12 / (1.0, 2.0) /
	data x3, i2 / 3.0, 2 /
	data ca / (1.0, 2.0), (3.0, 4.0), (5.0, 6.0) /

	rslts(1) = aimag(c12)
	rslts(2) = aimag( (3.5, -5.1e26) )
	rslts(3) = aimag(c12 + c12)
	rslts(4) = 2.0 * aimag(c12 * 5.0)
	rslts(5) = aimag( ca(i2) ) + x3
	rslts(6) = aimag( conjg(c12) )
	rslts(7) = conjg(c12 + c12)

c      complex function cf returns successive values:
c        (10,-10), (20,-20), (30,-30), ...

	rslts(8) = aimag(cf())
	rslts(9) = aimag( conjg(cf()) )

	crslts(1) = conjg((1.2, -2.3))
	crslts(2) = -conjg(c12 + c12)
	crslts(3) = c12 * conjg(ca(1))
	crslts(4) = conjg(cf()) + c12

c ---- check results:

	call check(rslts, expect, n)
	data expect / 2.0, -5.1e26, 4.0, 20.0, 7.0, -2.0, 2.0,
     +                -10.0, 20.0,
     +                1.2, 2.3,        -2.0, 4.0,
     +                5.0, 0.0,        31.0, 32.0             /
	end

	complex function cf()
	common c
	complex c
	data c / (10.0, -10.0) /
	cf = c
	c = c + (10.0, -10.0)
	return
	end


          program demo_sinh
          use, intrinsic :: iso_fortran_env, only : real_kinds, real32, real64, real128
          implicit none
            real(kind=real64) :: x = - 1.0_real64
            x = sinh(x)
          end program demo_sinh


submodule(euler_interface_m) euler_prob_0027_m
    implicit none

contains

    module character(len=20) function euler0027()
        write (euler0027, "(i20)") ans()
    end function euler0027

    integer function ans()
        integer :: a, b

        a = -(2*30 + 1)
        b = quadratic_primes(1, 41, 30)
        ans = a*b
    end function ans

    integer function quadratic_primes(i, j, n)
        integer, intent(in) :: i, j, n

        if (abs(i) >= 1000 .or. abs(j) > 1000) then
            quadratic_primes = 0
            return
        end if
        quadratic_primes = n**2 + i*n + j
    end function quadratic_primes

end submodule euler_prob_0027_m


subroutine cgln_amps

    implicit none

    include 'mpintp.inc'
    include 'spp.inc'

    integer l

    call multipole_amps

    call legendre

    if (method_helicity.eq.1) then

        ff1 = 0.0
        ff2 = 0.0
        ff3 = 0.0
        ff4 = 0.0
        ff5 = 0.0
        ff6 = 0.0

        do l = 0, wave_L

            if(l.lt.2) then
                ff1 = ff1 + (l * mp(l) + ep(l)) * pol(l + 1, 1)
            else
                ff1 = ff1 + (l * mp(l) + ep(l)) * pol(l + 1, 1)&
                        + ((l + 1) * mm(l) + em(l)) * pol(l - 1, 1)
            endif
        enddo

        do l = 1, wave_L
            ff2 = ff2 + ((l + 1) * mp(l) + l * mm(l)) * pol(l, 1)
            if(l.lt.2) then
                ff3 = ff3 + (ep(l) - mp(l)) * pol(l + 1, 2)
            else
                ff3 = ff3 + (ep(l) - mp(l)) * pol(l + 1, 2) + &
                        (em(l) + mm(l)) * pol(l - 1, 2)
            endif
        enddo

        do l = 2, wave_L
            ff4 = ff4 + (mp(l) - ep(l) - mm(l) - em(l)) * pol(l, 2)
        enddo

        do l = 0, wave_L
            if(l.lt.2) then
                ff5 = ff5 + (l + 1) * sp(l) * pol(l + 1, 1)
            else
                ff5 = ff5 + ((l + 1) * sp(l) * pol(l + 1, 1) - l * sm(l) * pol(l - 1, 1))
            endif
        enddo

        do l = 1, wave_L
            ff6 = ff6 + (l * sm(l) - (l + 1) * sp(l)) * pol(l, 1)
        enddo

    else
        do l = 0, max_L + 1
            ap(l) = 0.0
            am(l) = 0.0
            bp(l) = 0.0
            bm(l) = 0.0
            cp(l) = 0.0
            cm(l) = 0.0
        enddo

        do l = 0, max_L
            ap(l) = 0.5 * (l * mp(l) + (l + 2) * ep(l))
            am(l + 1) = 0.5 * ((l + 2) * mm(l + 1) - l * em(l + 1))
            bp(l) = ep(l) - mp(l)
            bm(l + 1) = em(l + 1) + mm(l + 1)
            cp(l) = (l + 1) * sp(l)
            cm(l + 1) = -(l + 1) * sm(l + 1)
        enddo

    endif

    return
end


program main
    use SiCroF
    implicit none
    type(FEMDomain_) :: sphere

    call sphere%create(Name="sphere",MeshType="Sphere3D",x_num=10,y_num=10,x_len=90.0d0, y_len=80.0d0,&
    thickness=70.0d0,division=10)
    call sphere%gmsh()

end program main


!*==dlarrc.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLARRC + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN,
!                                   EIGCNT, LCNT, RCNT, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBT
!       INTEGER            EIGCNT, INFO, LCNT, N, RCNT
!       DOUBLE PRECISION   PIVMIN, VL, VU
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   D( * ), E( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> Find the number of eigenvalues of the symmetric tridiagonal matrix T
!> that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
!> if JOBT = 'L'.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBT
!> \verbatim
!>          JOBT is CHARACTER*1
!>          = 'T':  Compute Sturm count for matrix T.
!>          = 'L':  Compute Sturm count for matrix L D L^T.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix. N > 0.
!> \endverbatim
!>
!> \param[in] VL
!> \verbatim
!>          VL is DOUBLE PRECISION
!>          The lower bound for the eigenvalues.
!> \endverbatim
!>
!> \param[in] VU
!> \verbatim
!>          VU is DOUBLE PRECISION
!>          The upper bound for the eigenvalues.
!> \endverbatim
!>
!> \param[in] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>          JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.
!>          JOBT = 'L': The N diagonal elements of the diagonal matrix D.
!> \endverbatim
!>
!> \param[in] E
!> \verbatim
!>          E is DOUBLE PRECISION array, dimension (N)
!>          JOBT = 'T': The N-1 offdiagonal elements of the matrix T.
!>          JOBT = 'L': The N-1 offdiagonal elements of the matrix L.
!> \endverbatim
!>
!> \param[in] PIVMIN
!> \verbatim
!>          PIVMIN is DOUBLE PRECISION
!>          The minimum pivot in the Sturm sequence for T.
!> \endverbatim
!>
!> \param[out] EIGCNT
!> \verbatim
!>          EIGCNT is INTEGER
!>          The number of eigenvalues of the symmetric tridiagonal matrix T
!>          that are in the interval (VL,VU]
!> \endverbatim
!>
!> \param[out] LCNT
!> \verbatim
!>          LCNT is INTEGER
!> \endverbatim
!>
!> \param[out] RCNT
!> \verbatim
!>          RCNT is INTEGER
!>          The left and right negcounts of the interval.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Contributors:
!  ==================
!>
!> Beresford Parlett, University of California, Berkeley, USA \n
!> Jim Demmel, University of California, Berkeley, USA \n
!> Inderjit Dhillon, University of Texas, Austin, USA \n
!> Osni Marques, LBNL/NERSC, USA \n
!> Christof Voemel, University of California, Berkeley, USA
!
!  =====================================================================
      SUBROUTINE DLARRC(Jobt,N,Vl,Vu,D,E,Pivmin,Eigcnt,Lcnt,Rcnt,Info)
      IMPLICIT NONE
!*--DLARRC140
!
!  -- LAPACK auxiliary routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobt
      INTEGER Eigcnt , Info , Lcnt , N , Rcnt
      DOUBLE PRECISION Pivmin , Vl , Vu
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION D(*) , E(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
!     ..
!     .. Local Scalars ..
      INTEGER i
      LOGICAL matt
      DOUBLE PRECISION lpivot , rpivot , sl , su , tmp , tmp2

!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. Executable Statements ..
!
      Info = 0
!
!     Quick return if possible
!
      IF ( N<=0 ) RETURN
!
      Lcnt = 0
      Rcnt = 0
      Eigcnt = 0
      matt = LSAME(Jobt,'T')

      IF ( matt ) THEN
!        Sturm sequence count on T
         lpivot = D(1) - Vl
         rpivot = D(1) - Vu
         IF ( lpivot<=ZERO ) Lcnt = Lcnt + 1
         IF ( rpivot<=ZERO ) Rcnt = Rcnt + 1
         DO i = 1 , N - 1
            tmp = E(i)**2
            lpivot = (D(i+1)-Vl) - tmp/lpivot
            rpivot = (D(i+1)-Vu) - tmp/rpivot
            IF ( lpivot<=ZERO ) Lcnt = Lcnt + 1
            IF ( rpivot<=ZERO ) Rcnt = Rcnt + 1
         ENDDO
      ELSE
!        Sturm sequence count on L D L^T
         sl = -Vl
         su = -Vu
         DO i = 1 , N - 1
            lpivot = D(i) + sl
            rpivot = D(i) + su
            IF ( lpivot<=ZERO ) Lcnt = Lcnt + 1
            IF ( rpivot<=ZERO ) Rcnt = Rcnt + 1
            tmp = E(i)*D(i)*E(i)
!
            tmp2 = tmp/lpivot
            IF ( tmp2==ZERO ) THEN
               sl = tmp - Vl
            ELSE
               sl = sl*tmp2 - Vl
            ENDIF
!
            tmp2 = tmp/rpivot
            IF ( tmp2==ZERO ) THEN
               su = tmp - Vu
            ELSE
               su = su*tmp2 - Vu
            ENDIF
         ENDDO
         lpivot = D(N) + sl
         rpivot = D(N) + su
         IF ( lpivot<=ZERO ) Lcnt = Lcnt + 1
         IF ( rpivot<=ZERO ) Rcnt = Rcnt + 1
      ENDIF
      Eigcnt = Rcnt - Lcnt

!
!     end of DLARRC
!
      END SUBROUTINE DLARRC


MODULE num_algorithm_concatenate_differ_operator
  ! Jianbo Long, Mar, 2020
  USE modelling_parameter, ONLY: modelling
  IMPLICIT NONE
  PRIVATE
  ! public procedures
  PUBLIC :: differ_operator_algorithm_concatenate
CONTAINS
  SUBROUTINE differ_operator_algorithm_concatenate()
    ! to modify the data in the linear system module accessed by 'USE-CALL-procedure'
    USE linear_system_equation_data, ONLY: initialize_matrices_operator
    USE scalar_FE_kernels_2d, ONLY: get_submatrix_operator_linearFE_triag, &
         get_submatrix_operator_quadFE_triag
    IMPLICIT NONE
    CALL initialize_matrices_operator()

    IF(modelling%FEdegree == 1) THEN
       CALL get_submatrix_operator_linearFE_triag()
    ELSEIF(modelling%FEdegree == 2) THEN
       CALL get_submatrix_operator_quadFE_triag()
    END IF
    RETURN
  end SUBROUTINE differ_operator_algorithm_concatenate
end MODULE num_algorithm_concatenate_differ_operator


subroutine fruler
use fdeclarations

implicit none
allocate(pmatrix(nn,w+2))
allocate(p22matrix(nn,w-2))
allocate(p11matrix(nn,w,n))
pmatrix(:,:)=0
p22matrix(:,:)=0

do i=1,nn !For the nn combinations of the amatrix
do j=1,ii !And for the  samples
if ((amatrix(i,1) .eq. cmatrix(j,1)) .and. (amatrix(i,2) .eq. cmatrix(j,2)) &
.and. (amatrix(i,3) .eq. cmatrix(j,3)) .and. (amatrix(i,4) .eq. cmatrix(j,4))) then !If any row of the class matrix equals a row in the amatrix
if (cmatrix(j,5) .eq. 5) then !Then check the suitability class and
pmatrix(i,1)=pmatrix(i,1)+0.9
pmatrix(i,w+2)=pmatrix(i,w+2)+1
p11matrix(i,1,j)=0.9 !Make a new matrix with the suitabilities at each column
else if (cmatrix(j,5) .eq. 4) then
pmatrix(i,2)=pmatrix(i,2)+0.7
pmatrix(i,w+2)=pmatrix(i,w+2)+1
p11matrix(i,2,j)=0.7 !And assign 1 to the relevant suitability column
else if (cmatrix(j,5) .eq. 3) then
pmatrix(i,3)=pmatrix(i,3)+0.5
pmatrix(i,w+2)=pmatrix(i,w+2)+1
p11matrix(i,3,j)=0.5
else if (cmatrix(j,5) .eq. 2) then
pmatrix(i,4)=pmatrix(i,4)+0.3
pmatrix(i,w+2)=pmatrix(i,w+2)+1
p11matrix(i,4,j)=0.3
else if (cmatrix(j,5) .eq. 1) then
pmatrix(i,5)=pmatrix(i,5)+0.1
pmatrix(i,w+2)=pmatrix(i,w+2)+1
p11matrix(i,5,j)=0.1
end if
end if
end do
end do

do i=1,nn
pmatrix(i,w+1)=sum(pmatrix(i,1:w)) !Then attach an extra column where all values will be sumed
end do

do i=1,nn
do j=1,z
if (pmatrix(i,w+1)>0) then
p22matrix(i,1)=pmatrix(i,w+1)/pmatrix(i,w+2)
p22matrix(i,2)=(minval(p11matrix(i,1:w,:), mask=(p11matrix(i,1:w,:))>0))
p22matrix(i,3)=(maxval(p11matrix(i,1:w,:), mask=(p11matrix(i,1:w,:))>0))
else
p22matrix(i,:)=0
end if
end do
end do

end subroutine fruler


module asflowf_cube_diff_1d

    use asflowf_crystal, only : write_xyz
    use asflowf_cube, only : cube
    use asflowf_constants

    implicit none

    contains

    subroutine cube_diff_1d(cube_file_in_iii)

        type(cube), dimension(3) :: cube_iii

        integer :: i, j, k
        integer :: natom, ngridx, ngridy, ngridz
        real(kind=dp), allocatable :: data_diff(:, :, :), data_red_a(:), data_red_b(:), data_red_c(:)

        real(kind=dp) :: cell_volume, cell_volume_per_unit, tmp, tmp_vec(3)
        real(kind=dp) :: a, b, c
        real(kind=dp) :: total_electron

        !character(len=128), dimension(3), intent(in) :: cube_file_in_iii
        character(len=*), dimension(3), intent(in) :: cube_file_in_iii

        ! read cube file

        if ( cube_file_in_iii(1) == "") then
            write(*, *) "You should provide the name for the input cube file!"
            stop
        else
            write(*, *) "The input cube file name is: "
            write(*, *) cube_file_in_iii(1)
            write(*, *) cube_file_in_iii(2)
            write(*, *) cube_file_in_iii(3)
        end if

        ! read in the input cube file
        call cube_iii(1)%read_cube_file(cube_file_in_iii(1))
        call cube_iii(2)%read_cube_file(cube_file_in_iii(2))
        call cube_iii(3)%read_cube_file(cube_file_in_iii(3))

        ngridx = cube_iii(1)%ngridx
        ngridy = cube_iii(1)%ngridy
        ngridz = cube_iii(1)%ngridz

        ! value in cube file are \rho(r)_of_electrons in unit of e/Bohr^3
        ! namely number of electrons each Borh^3
        ! so we have to convert it to e/Angstrom^3, through divide it by bohr_to_angstrom**3

        call cross_3(cube_iii(1)%cube_crystal%cell(1, :), cube_iii(1)%cube_crystal%cell(2, :), tmp_vec)

        call dot_3(tmp_vec, cube_iii(1)%cube_crystal%cell(3, :), cell_volume)

        cell_volume_per_unit = cell_volume / ngridx / ngridy / ngridz

        data_diff = cube_iii(1)%data - cube_iii(2)%data - cube_iii(3)%data

        total_electron = sum(cube_iii(1)%data) * cell_volume_per_unit / bohr_to_angstrom**3

        write(*, *) "-----------------------------------------------------------------"
        write(*, *) "                 Out put collected information                   "
        write(*, *) "-----------------------------------------------------------------"
        write(*, *) "ngridx: ", ngridx
        write(*, *) "ngridy: ", ngridy
        write(*, *) "ngridz: ", ngridz
        write(*, *) "cell volume: ", cell_volume
        write(*, *) "total number of electrons: ", total_electron
        write(*, *) "-----------------------------------------------------------------"

        allocate(data_red_a(ngridx))
        allocate(data_red_b(ngridy))
        allocate(data_red_c(ngridz))

        !$OMP PARALLEL DO
        do i = 1, ngridx
            data_red_a(i) = 0
            do j = 1, ngridy
                do k = 1, ngridz
                    data_red_a(i) =  data_red_a(i) + data_diff(i, j, k)
                end do
            end do
        end do
        !$OMP END PARALLEL DO
        data_red_a = data_red_a * cell_volume_per_unit / bohr_to_angstrom**3

        !$OMP PARALLEL
        !$OMP DO
        do j = 1, ngridy
            data_red_b(j) = 0
            do i = 1, ngridx
                do k = 1, ngridz
                    data_red_b(j) = data_red_b(j) + data_diff(i, j, k)
                end do
            end do
        end do
        !$OMP END DO
        !$OMP END PARALLEL
        data_red_b = data_red_b * cell_volume_per_unit / bohr_to_angstrom**3

        !$OMP PARALLEL
        !$OMP DO
        do k = 1, ngridz
            data_red_c(k) = 0
            do i = 1, ngridx
                do j = 1, ngridy
                    data_red_c(k) = data_red_c(k) + data_diff(i, j, k)
                end do
            end do
        end do
        !$OMP END DO
        !$OMP END PARALLEL
        data_red_c = data_red_c * cell_volume_per_unit / bohr_to_angstrom**3

        call dot_3(cube_iii(1)%cube_crystal%cell(1, :), cube_iii(1)%cube_crystal%cell(1, :), a)
        a = sqrt(a)
        call dot_3(cube_iii(1)%cube_crystal%cell(2, :), cube_iii(1)%cube_crystal%cell(2, :), b)
        b = sqrt(b)
        call dot_3(cube_iii(1)%cube_crystal%cell(3, :), cube_iii(1)%cube_crystal%cell(3, :), c)
        c = sqrt(c)

        ! output dimension reduced data
        open(unit=11, file="diff.charge.1d.c.data", action="write")
        write(11, *) "#c(angstrom) \delta(rho(e)) (number of electron per Angstrom)"
        do i = 1, ngridz
            write(11, *) (0 + c / (ngridz - 1) * (i - 1)), data_red_c(i)
        end do
        close(unit=11)

        open(unit=11, file="diff.charge.1d.b.data", action="write")
        write(11, *) "#b(angstrom) \delta(rho(e)) (number of electron per Angstrom)"
        do i = 1, ngridy
            write(11, *) (0 + b / (ngridy - 1) * (i - 1)), data_red_b(i)
        end do
        close(unit=11)

        open(unit=11, file="diff.charge.1d.a.data", action="write")
        write(11, *) "#a(angstrom) \delta(rho(e)) (number of electron per Angstrom)"
        do i = 1, ngridx
            write(11, *) (0 + a / (ngridx - 1) * (i - 1)), data_red_a(i)
        end do
        close(unit=11)

        ! output the total structure
        call write_xyz(cube_iii(1)%cube_crystal, "diff-charge-total.xyz")

        stop
    end subroutine cube_diff_1d

    subroutine cross_3(x, y, z)
        implicit none
        real(kind=dp), dimension(3), intent(in) :: x, y
        real(kind=dp), dimension(3), intent(out) :: z

        z(1) = x(2) * y(3) - x(3) * y(2)
        z(2) = x(3) * y(1) - x(1) * y(3)
        z(3) = x(1) * y(2) - x(2) * y(1)
    end subroutine

    subroutine dot_3(x, y, z)
        implicit none
        real(kind=dp), dimension(3), intent(in) :: x, y
        real(kind=dp), intent(out) :: z
        z = x(1) * y(1) + x(2) * y(2) + x(3) * y(3)
    end subroutine dot_3
end module asflowf_cube_diff_1d


!*==chptrd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CHPTRD
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CHPTRD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, N
!       ..
!       .. Array Arguments ..
!       REAL               D( * ), E( * )
!       COMPLEX            AP( * ), TAU( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CHPTRD reduces a complex Hermitian matrix A stored in packed form to
!> real symmetric tridiagonal form T by a unitary similarity
!> transformation: Q**H * A * Q = T.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] AP
!> \verbatim
!>          AP is COMPLEX array, dimension (N*(N+1)/2)
!>          On entry, the upper or lower triangle of the Hermitian matrix
!>          A, packed columnwise in a linear array.  The j-th column of A
!>          is stored in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!>          On exit, if UPLO = 'U', the diagonal and first superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          tridiagonal matrix T, and the elements above the first
!>          superdiagonal, with the array TAU, represent the unitary
!>          matrix Q as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and first subdiagonal of A are over-
!>          written by the corresponding elements of the tridiagonal
!>          matrix T, and the elements below the first subdiagonal, with
!>          the array TAU, represent the unitary matrix Q as a product
!>          of elementary reflectors. See Further Details.
!> \endverbatim
!>
!> \param[out] D
!> \verbatim
!>          D is REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!> \endverbatim
!>
!> \param[out] E
!> \verbatim
!>          E is REAL array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is COMPLEX array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(n-1) . . . H(2) H(1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
!>  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(n-1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
!>  overwriting A(i+2:n,i), and tau is stored in TAU(i).
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CHPTRD(Uplo,N,Ap,D,E,Tau,Info)
      IMPLICIT NONE
!*--CHPTRD155
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , N
!     ..
!     .. Array Arguments ..
      REAL D(*) , E(*)
      COMPLEX Ap(*) , Tau(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX ONE , ZERO , HALF
      PARAMETER (ONE=(1.0E+0,0.0E+0),ZERO=(0.0E+0,0.0E+0),              &
     &           HALF=(0.5E+0,0.0E+0))
!     ..
!     .. Local Scalars ..
      LOGICAL upper
      INTEGER i , i1 , i1i1 , ii
      COMPLEX alpha , taui
!     ..
!     .. External Subroutines ..
      EXTERNAL CAXPY , CHPMV , CHPR2 , CLARFG , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      COMPLEX CDOTC
      EXTERNAL LSAME , CDOTC
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC REAL
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      Info = 0
      upper = LSAME(Uplo,'U')
      IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CHPTRD',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N<=0 ) RETURN
!
      IF ( upper ) THEN
!
!        Reduce the upper triangle of A.
!        I1 is the index in AP of A(1,I+1).
!
         i1 = N*(N-1)/2 + 1
         Ap(i1+N-1) = REAL(Ap(i1+N-1))
         DO i = N - 1 , 1 , -1
!
!           Generate elementary reflector H(i) = I - tau * v * v**H
!           to annihilate A(1:i-1,i+1)
!
            alpha = Ap(i1+i-1)
            CALL CLARFG(i,alpha,Ap(i1),1,taui)
            E(i) = alpha
!
            IF ( taui/=ZERO ) THEN
!
!              Apply H(i) from both sides to A(1:i,1:i)
!
               Ap(i1+i-1) = ONE
!
!              Compute  y := tau * A * v  storing y in TAU(1:i)
!
               CALL CHPMV(Uplo,i,taui,Ap,Ap(i1),1,ZERO,Tau,1)
!
!              Compute  w := y - 1/2 * tau * (y**H *v) * v
!
               alpha = -HALF*taui*CDOTC(i,Tau,1,Ap(i1),1)
               CALL CAXPY(i,alpha,Ap(i1),1,Tau,1)
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w**H - w * v**H
!
               CALL CHPR2(Uplo,i,-ONE,Ap(i1),1,Tau,1,Ap)
!
            ENDIF
            Ap(i1+i-1) = E(i)
            D(i+1) = Ap(i1+i)
            Tau(i) = taui
            i1 = i1 - i
         ENDDO
         D(1) = Ap(1)
      ELSE
!
!        Reduce the lower triangle of A. II is the index in AP of
!        A(i,i) and I1I1 is the index of A(i+1,i+1).
!
         ii = 1
         Ap(1) = REAL(Ap(1))
         DO i = 1 , N - 1
            i1i1 = ii + N - i + 1
!
!           Generate elementary reflector H(i) = I - tau * v * v**H
!           to annihilate A(i+2:n,i)
!
            alpha = Ap(ii+1)
            CALL CLARFG(N-i,alpha,Ap(ii+2),1,taui)
            E(i) = alpha
!
            IF ( taui/=ZERO ) THEN
!
!              Apply H(i) from both sides to A(i+1:n,i+1:n)
!
               Ap(ii+1) = ONE
!
!              Compute  y := tau * A * v  storing y in TAU(i:n-1)
!
               CALL CHPMV(Uplo,N-i,taui,Ap(i1i1),Ap(ii+1),1,ZERO,Tau(i),&
     &                    1)
!
!              Compute  w := y - 1/2 * tau * (y**H *v) * v
!
               alpha = -HALF*taui*CDOTC(N-i,Tau(i),1,Ap(ii+1),1)
               CALL CAXPY(N-i,alpha,Ap(ii+1),1,Tau(i),1)
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w**H - w * v**H
!
               CALL CHPR2(Uplo,N-i,-ONE,Ap(ii+1),1,Tau(i),1,Ap(i1i1))
!
            ENDIF
            Ap(ii+1) = E(i)
            D(i) = Ap(ii)
            Tau(i) = taui
            ii = i1i1
         ENDDO
         D(N) = Ap(ii)
      ENDIF
!
!
!     End of CHPTRD
!
      END SUBROUTINE CHPTRD