resrings.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 FUNCTION recrings(VID)
 
USE parameters
 
IMPLICIT NONE
 
INTEGER, INTENT(IN) :: vid
 
DOUBLE PRECISION :: mamp, eamp
DOUBLE PRECISION :: tamp, etamp
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: amp
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: ringspna, ectrpna
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: emin, emax
DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: mpna
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: rtab
 
if (tbr) then
 
  recrings=2
  goto 001
 
else if (alc) then
 
  recrings=0
  goto 001
 
endif
 
if (allocated(rtab)) deallocate(rtab)
allocate(rtab(taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: RTAB"//char(0))
  recrings=0
  goto 001
endif
if (allocated(moyred)) deallocate(moyred)
allocate(moyred(taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: MOYRED"//char(0))
  recrings=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: RECRINGS"//char(0), "Table: RED"//char(0))
  recrings=0
  goto 001
endif
if (allocated(ectype)) deallocate(ectype)
allocate(ectype(taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: ECTYPE"//char(0))
  recrings=0
  goto 001
endif
!if (allocated(MOYPUR)) deallocate(MOYPUR)
!allocate(MOYPUR(TAILLR), STAT=ERR)
!if (ERR .ne. 0) then
!  call show_error ("Impossible to allocate memory"//CHAR(0), &
!                   "Function: RECRINGS"//CHAR(0), "Table: MOYPUR"//CHAR(0))
!  RECRINGS=0
!  goto 001
!endif
!if (allocated(IRRED)) deallocate(IRRED)
!allocate(IRRED(NS), STAT=ERR)
!if (ERR .ne. 0) then
!  call show_error ("Impossible to allocate memory"//CHAR(0), &
!                   "Function: RECRINGS"//CHAR(0), "Table: IRRED"//CHAR(0))
!  RECRINGS=0
!  goto 001
!endif
!if (allocated(ECTYP)) deallocate(ECTYP)
!allocate(ECTYP(TAILLR), STAT=ERR)
!if (ERR .ne. 0) then
!  call show_error ("Impossible to allocate memory"//CHAR(0), &
!                   "Function: RECRINGS"//CHAR(0), "Table: ECTYP"//CHAR(0))
!  RECRINGS=0
!  goto 001
!endif
 
ectype(:)=0.0d0
!ECTYP(:)=0.0d0
 
do l=3, taillr
  do i=1, ns
    red(i)=dble(nring(l,i))/ntlt
!    IRRED(i)=dble(NIRR(l,i))/NTLT
  enddo
  if (ns .gt. 1) then
    moyred(l)=0.0d0
!    MOYPUR(l)=0.0d0
    ectype(l)=0.0d0
!    ECTYP(l)=0.0d0
    call moyenne(red, ns, moyred(l))
!    call MOYENNE(IRRED, NS, MOYPUR(l))
    call ect_type(moyred(l), red, ns, ectype(l))
!    call ECT_TYPE(MOYPUR(l), IRRED, NS, ECTYP(l))
  else
    moyred(l)=red(1)
!    MOYPUR(l)=IRRED(1)
  endif
enddo
 
tamp=0.0
do i=3, taillr
  rtab(i)=moyred(i)
  tamp = tamp + rtab(i)
enddo
 
if (tamp .eq. 0.0) then
  recrings=1
  goto 001
endif
 
l=(nsp+1)*4*vid
if (tlt .ne. nsp+1) l = l + 4*tlt
call save_curve (taillr, rtab, l, idri)
 
if (allocated(mpna)) deallocate(mpna)
allocate(mpna(taillr,taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: MPNA"//char(0))
  recrings=0
  goto 001
endif
if (allocated(epna)) deallocate(epna)
allocate(epna(taillr,taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: EPNA"//char(0))
  recrings=0
  goto 001
endif
if (allocated(ringspna)) deallocate(ringspna)
allocate(ringspna(taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: RINGSPNA"//char(0))
  recrings=0
  goto 001
endif
if (allocated(ectrpna)) deallocate(ectrpna)
allocate(ectrpna(taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: ECTPNA"//char(0))
  recrings=0
  goto 001
endif
if (allocated(rnamax)) deallocate(rnamax)
allocate(rnamax(taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: RNAMAX"//char(0))
  recrings=0
  goto 001
endif
if (allocated(rnamin)) deallocate(rnamin)
allocate(rnamin(taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: RNAMIN"//char(0))
  recrings=0
  goto 001
endif
if (allocated(emax)) deallocate(emax)
allocate(emax(taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: EMAX"//char(0))
  recrings=0
  goto 001
endif
if (allocated(emin)) deallocate(emin)
allocate(emin(taillr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: EMIN"//char(0))
  recrings=0
  goto 001
endif
if (allocated(mtabl)) deallocate(mtabl)
allocate(mtabl(ns), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: MTABL"//char(0))
  recrings=0
  goto 001
endif
 
ringspna(:)=0.0d0
ectrpna(:)=0.0d0
rnamax(:)=0.0d0
rnamin(:)=0.0d0
emax(:)=0.0d0
emin(:)=0.0d0
mpna(:,:)=0.0d0
epna(:,:)=0.0d0
 
do i=3, taillr
  do j=3, taillr
    if (ns .gt. 1) then
      do k=1, ns
        mtabl(k)=pna(i,j,k)
      enddo
      call moyenne(mtabl, ns, mpna(i,j))
      call ect_type(mpna(i,j), mtabl, ns, epna(i,j))
      if (i.eq.j) then
        ringspna(i)=mpna(i,j)/ntlt
        ectrpna(i)=epna(i,j)/ntlt
      endif
    else
      mpna(i,j)=dble(pna(i,j,1))/ntlt
      if (i.eq.j) ringspna(i)=mpna(i,j)
    endif
  enddo
enddo
 
do i=1, taillr
  rtab(i)=ringspna(i)
enddo
l=l+1
call save_curve (taillr, rtab, l, idri)
 
do i=1, taillr
  if (ns .gt. 1) then
    m=0
    do j=1, ns
      if (pna(i,i,j) .eq. 0) then
        mtabl(j)=0.0d0
      else
        m=m+1
        mtabl(j)=dble(maxpna(i,j))/dble(pna(i,i,j))
      endif
    enddo
    if (m.gt.1) then
      call moyenne(mtabl, ns, rnamax(i))
      rnamax(i)=rnamax(i)*ns/m
      call ect_type_rings(rnamax(i), mtabl, ns, m, emax(i))
    elseif (m.eq.1) then
      rnamax(i)=rnamax(i)*ns
      emax(i)=0.0d0
    else
      rnamax(i)=0.0d0
      emax(i)=0.0d0
    endif
    m=0
    do j=1, ns
      if (pna(i,i,j) .eq. 0) then
        mtabl(j)=0.0d0
      else
        m=m+1
        mtabl(j)=dble(minpna(i,j))/dble(pna(i,i,j))
      endif
    enddo
    if (m.gt.1) then
      call moyenne(mtabl, ns, rnamin(i))
      rnamin(i)=rnamin(i)*ns/m
      call ect_type_rings(rnamin(i), mtabl, ns, m, emin(i))
    elseif (m.eq.1) then
      rnamin(i)=rnamin(i)*ns
      emin(i)=0.0d0
    else
      rnamin(i)=0.0d0
      emin(i)=0.0d0
    endif
  else
    if (pna(i,i,1).eq.0.0) then
      rnamax(i)=0.0d0
      emax(i)=0.0d0
      rnamin(i)=0.0d0
      emin(i)=0.0d0
    else
      rnamax(i)=dble(maxpna(i,1))/pna(i,i,1)
      emax(i)=0.0d0
      rnamin(i)=dble(minpna(i,1))/pna(i,i,1)
      emin(i)=0.0d0
    endif
  endif
enddo
 
do i=1, taillr
  rtab(i)=rnamax(i)
enddo
l=l+1
call save_curve (taillr, rtab, l, idri)
do i=1, taillr
  rtab(i)=rnamin(i)
enddo
l=l+1
call save_curve (taillr, rtab, l, idri)
 
if (allocated(amp)) deallocate(amp)
allocate(amp(ns), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: RECRINGS"//char(0), "Table: AMP"//char(0))
  recrings=0
  goto 001
endif
 
do i=1, ns
  amp(i)=0.0d0
  if (doampat) then
    do j=1, ntlt
      amp(i)=amp(i)+dble(ampat(j,i))
    enddo
  endif
enddo
mamp=0.0d0
eamp=0.0d0
if (doampat) then
  if (ns .gt. 1) then
    call moyenne(amp, ns, mamp)
    call ect_type(mamp, amp, ns, eamp)
  else
    mamp=amp(1)
  endif
endif
 
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: RECRINGS"//char(0), "Table: TOTPSTEP"//char(0))
  recrings=0
  goto 001
endif
 
do i=1, ns
  totpstep(i)=0
  do j=3, taillr
    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_rings_data (taillr, ectype, ectrpna, emax, emin, tamp, etamp, mamp, eamp)
 
recrings=1
 
001 continue
 
if (allocated(rtab)) deallocate(rtab)
if (allocated(ampat)) deallocate(ampat)
if (allocated(amp)) deallocate(amp)
if (allocated(totpstep)) deallocate(totpstep)
if (allocated(moyred)) deallocate(moyred)
if (allocated(red)) deallocate(red)
if (allocated(ectype)) deallocate(ectype)
!if (allocated(MOYPUR)) deallocate(MOYPUR)
!if (allocated(IRRED)) deallocate(IRRED)
!if (allocated(ECTYP)) deallocate(ECTYP)
if (allocated(mpna)) deallocate(mpna)
if (allocated(epna)) deallocate(epna)
if (allocated(ringspna)) deallocate(ringspna)
if (allocated(ectrpna)) deallocate(ectrpna)
if (allocated(rnamax)) deallocate(rnamax)
if (allocated(rnamin)) deallocate(rnamin)
if (allocated(emax)) deallocate(emax)
if (allocated(emin)) deallocate(emin)
if (allocated(mtabl)) deallocate(mtabl)
if (allocated(nring)) deallocate(nring)
 
END FUNCTION