initchains.F90

Go to the documentation of this file.

! This file is part of the 'atomes' software.
!
! 'atomes' is free software: you can redistribute it and/or modify it under the terms
! of the GNU Affero General Public License as published by the Free Software Foundation,
! either version 3 of the License, or (at your option) any later version.
!
! 'atomes' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
! without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
! See the GNU General Public License for more details.
!
! You should have received a copy of the GNU Affero General Public License along with 'atomes'.
! If not, see <https://www.gnu.org/licenses/>
!
! Copyright (C) 2022-2024 by CNRS and University of Strasbourg
!
 
INTEGER (KIND=c_int) FUNCTION initchains (VTLT, VAAA, VACA, VHOMO, V121, VTAILLC, VNUMA) bind (C,NAME='initchains_')
 
!
! Initialization of the chain statistics
! The key variable is NUMA see in the following lines
!
 
USE parameters
 
IMPLICIT NONE
 
INTEGER (KIND=c_int), INTENT(IN) :: vtlt, vaaa, vaca, vhomo, v121, vtaillc, vnuma
 
INTERFACE
  INTEGER FUNCTION chains()
  END FUNCTION
END INTERFACE
 
  if (vtlt .eq. 0) then
    tlt=nsp+1
  else
    tlt=vtlt
  endif
  numa=vnuma
  ntlt=nbspbs(tlt)
  taillc=vtaillc
 
  aaaa=.false.
  acac=.false.
  no_homo=.false.
  if (nsp.gt. 1) then
    if (vaaa == 1) aaaa=.true.
    if (vaca == 1) acac=.true.
    if (vhomo == 1) no_homo=.true.
  endif
  isolated=.false.
  if (v121 == 1) isolated=.true.
#ifdef DEBUG
  write (6, '("CHAINS:: AAAA= ",l1,", ACAC= ",l1,", NO_HOMO= ",l1,", ISOLATED= ",l1)') aaaa, acac, no_homo, isolated
#endif
  tbr=.false.
  alc=.false.
 
  initchains = chains()
 
END FUNCTION
 
INTEGER FUNCTION rechains()
 
USE parameters
 
IMPLICIT NONE
 
DOUBLE PRECISION :: tamp, etamp
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: ctab
 
allocate(ctab(taillc), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECHAINS"//char(0), "Table: CTAB"//char(0))
  rechains=0
  goto 001
endif
if (allocated(red)) deallocate(red)
allocate(red(ns), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECHAINS"//char(0), "Table: RED"//char(0))
  rechains=0
  goto 001
endif
if (allocated(moyred)) deallocate(moyred)
allocate(moyred(taillc), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECHAINS"//char(0), "Table: MOYRED"//char(0))
  rechains=0
  goto 001
endif
if (allocated(ectype)) deallocate(ectype)
allocate(ectype(taillc), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECHAINS"//char(0), "Table: ECTYPE"//char(0))
  rechains=0
  goto 001
endif
 
red(:)=0.0d0
 
do l=1, taillc
  do i=1, ns
    red(i)=dble(nring(l,i))/ntlt
  enddo
  if (ns .gt. 1) then
    moyred(l)=0.0d0
    ectype(l)=0.0d0
    call moyenne(red, ns, moyred(l))
    call ect_type(moyred(l), red, ns, ectype(l))
  else
    moyred(l)=red(1)
  endif
enddo
 
tamp=0.0
do i=1, taillc
  ctab(i)=moyred(i)
  tamp = tamp + ctab(i)
enddo
 
if (tamp .eq. 0.0) then
  rechains=1
  goto 001
endif
 
l=0
if (tlt .ne. nsp+1) l = l + tlt
 
call save_curve (taillc, ctab, l, idch)
 
if (allocated(totpstep)) deallocate(totpstep)
allocate(totpstep(ns), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECHAINS"//char(0), "Table: TOTPSTEP"//char(0))
  rechains=0
  goto 001
endif
 
do i=1, ns
  totpstep(i)=0
  do j=1, taillc
    totpstep(i)=totpstep(i)+dble(nring(j,i))
  enddo
enddo
 
tamp=0.0d0
etamp=0.0d0
call moyenne(totpstep, ns, tamp)
call ect_type(tamp, totpstep, ns, etamp)
call save_chains_data (taillc, ectype, tamp, etamp)
 
rechains=1
 
001 continue
 
if (allocated(totpstep)) deallocate(totpstep)
if (allocated(moyred)) deallocate(moyred)
if (allocated(red)) deallocate(red)
if (allocated(ctab)) deallocate(ctab)
 
END FUNCTION