atomes 1.1.14
atomes: an atomic scale modeling tool box
Loading...
Searching...
No Matches
chains.F90
Go to the documentation of this file.
1! This file is part of the 'atomes' software.
2!
3! 'atomes' is free software: you can redistribute it and/or modify it under the terms
4! of the GNU Affero General Public License as published by the Free Software Foundation,
5! either version 3 of the License, or (at your option) any later version.
6!
7! 'atomes' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
8! without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
9! See the GNU General Public License for more details.
10!
11! You should have received a copy of the GNU Affero General Public License along with 'atomes'.
12! If not, see <https://www.gnu.org/licenses/>
13!
14! Copyright (C) 2022-2024 by CNRS and University of Strasbourg
15!
20
21SUBROUTINE setup_cpat_vpat_chain (CONT, VOIS, STR, CPT, VPT)
22
23USE parameters
24
25IMPLICIT NONE
26
27INTEGER, INTENT(IN) :: STR
28INTEGER, DIMENSION(NA,NS), INTENT(IN):: CONT
29INTEGER, DIMENSION(MAXN,NA,NS), INTENT(IN) :: VOIS
30INTEGER, DIMENSION(NA), INTENT(INOUT):: CPT
31INTEGER, DIMENSION(NA,MAXN), INTENT(INOUT) :: VPT
32INTEGER :: RAB, RAC
33
34!do RAB=1, NAT
35! write (6, '("At= ",i4," Neigh= ",i2)') RAB, CONTJ(RAB,STR)
36! do RAC=1, CONTJ(RAB,STR)
37! write (6, '(" i= ",i2," Vois= ",i4)') RAC, VOISJ(RAC,RAB,STR)
38! enddo
39!enddo
40
41cpt(:) = 0
42vpt(:,:) = 0
43
44do rab=1, na
45 cpt(rab) = cont(rab,str)
46 do rac=1, cont(rab,str)
47 vpt(rab,rac) = vois(rac,rab,str)
48 enddo
49enddo
50
51END SUBROUTINE
52
53INTEGER FUNCTION chains()
54
55USE parameters
56
57#ifdef OPENMP
58!$ USE OMP_LIB
59#endif
60IMPLICIT NONE
61
62#ifdef OPENMP
63INTEGER :: numth
64LOGICAL :: doatoms
65#endif
66
67INTERFACE
68 INTEGER FUNCTION rechains ()
69 END FUNCTION
70END INTERFACE
71
72chains = 0
73
74#ifdef OPENMP
75numth = omp_get_max_threads()
76doatoms=.false.
77if (ns.ge.1 .and. ns.lt.numth) then
78 if (numth .ge. 2*(ns-1)) then
79 doatoms=.true.
80 else
81 numth=ns
82 endif
83endif
84
85if (all_atoms) doatoms=.true.
86
87if (doatoms) then
88 if (na.lt.numth) numth=na
89#ifdef DEBUG
90 write (6, *) "OpenMP on atoms, NUMTH= ",numth
91#endif
92 call chains_search_atoms (numth)
93else
94#ifdef DEBUG
95 write (6, *) "OpenMP on MD steps, NUMTH= ",numth
96#endif
97 call chains_search_steps (numth)
98endif
99#else
100call chains_search_steps ()
101#endif
102
103chains = rechains()
104
105END FUNCTION
106
107#ifdef OPENMP
108SUBROUTINE chains_search_atoms (NUMTH)
109
110USE parameters
111
112!$ USE OMP_LIB
113IMPLICIT NONE
114
115INTEGER, INTENT(IN) :: numth
116TYPE (ring), DIMENSION(:), ALLOCATABLE :: the_chain
117INTEGER, DIMENSION(:), ALLOCATABLE :: tring, indte
118INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: savring
119INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: savr
120INTEGER :: lora, lorb, res, ch
121
122INTERFACE
123 INTEGER FUNCTION check_chain (THE_CHAIN, CHAINE, TAE, RSAVED, TRING, INDE, RESL)
124 USE parameters
125 TYPE (ring), DIMENSION(TAILLC), INTENT(IN) :: the_chain
126 INTEGER, INTENT(IN) :: chaine
127 INTEGER, INTENT(INOUT) :: tae
128 INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: rsaved
129 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: tring
130 INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: inde
131 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: resl
132 END FUNCTION
133 RECURSIVE SUBROUTINE inside_chain (THE_CHAIN, CID, TAE, LRA, LRB, NRPAT, RSAVED, TRING, INDE, RESL, CPT, VPT)
134 USE parameters
135 TYPE (ring), DIMENSION(TAILLC), INTENT(INOUT) :: the_chain
136 INTEGER, INTENT(IN) :: cid, lra, lrb
137 INTEGER, INTENT(INOUT) :: tae
138 INTEGER, DIMENSION(NA), INTENT(INOUT) :: nrpat
139 INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: rsaved
140 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: tring
141 INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: inde
142 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: resl
143 INTEGER, DIMENSION(NA), INTENT(IN):: cpt
144 INTEGER, DIMENSION(NA,MAXN), INTENT(IN) :: vpt
145 END SUBROUTINE
146 INTEGER FUNCTION chains_to_ogl (STEP, NRI, RSAVED)
147 USE parameters
148 INTEGER, INTENT(IN) :: step
149 INTEGER, DIMENSION(TAILLC, NS), INTENT(IN) :: nri
150 INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(IN) :: rsaved
151 END FUNCTION
152 INTEGER FUNCTION chains_to_ogl_menu (NRI)
153 USE parameters
154 INTEGER, DIMENSION(TAILLC, NS), INTENT(IN) :: nri
155 END FUNCTION
156END INTERFACE
157
158ch = 0
159if (allocated(nring)) deallocate(nring)
160allocate(nring(taillc,ns), stat=err)
161if (err .ne. 0) then
162 alc_tab="NRING"
163 alc=.true.
164 goto 001
165endif
166nring(:,:) = 0
167if(allocated(savring)) deallocate(savring)
168allocate(savring(taillc,numa,taillc), stat=err)
169if (err .ne. 0) then
170 alc_tab="SAVRING"
171 alc=.true.
172 goto 001
173endif
174if(allocated(cpat)) deallocate(cpat)
175allocate(cpat(na), stat=err)
176if (err .ne. 0) then
177 alc_tab="CPAT"
178 alc=.true.
179 goto 001
180endif
181 if(allocated(vpat)) deallocate(vpat)
182allocate(vpat(na,maxn), stat=err)
183if (err .ne. 0) then
184 alc_tab="VPAT"
185 alc=.true.
186 goto 001
187endif
188
189do i=1, ns
190
191 savring(:,:,:)=0
192 call setup_cpat_vpat_chain (contj, voisj, i, cpat, vpat)
193
194 ! OpenMP on atoms only
195 !$OMP PARALLEL NUM_THREADS(NUMTH) DEFAULT (NONE) &
196 !$OMP& PRIVATE(THE_CHAIN, RPAT, RUNSEARCH, ERR, SAVR, TRING, INDTE, &
197 !$OMP& j, k, l, m, n, o, LORA, LORB, RES, RES_LIST, TAILLE, SAUT) &
198 !$OMP& SHARED(i, p, NUMTH, NS, NA, TLT, NSP, LOT, ISOLATED, CONTJ, VOISJ, CPAT, VPAT, &
199 !$OMP& NUMA, MAXN, ACAC, AAAA, NOHP, TAILLC, TBR, ALC, ALC_TAB, NCELLS, PBC, SAVRING, NRING, ch)
200
201 if (allocated(rpat)) deallocate(rpat)
202 allocate(rpat(na), stat=err)
203 if (err .ne. 0) then
204 alc_tab="RAPT"
205 alc=.true.
206 goto 003
207 endif
208 if(allocated(res_list)) deallocate(res_list)
209 allocate(res_list(taillc), stat=err)
210 if (err .ne. 0) then
211 alc_tab="RES_LIST"
212 alc=.true.
213 goto 003
214 endif
215 if(allocated(indte)) deallocate(indte)
216 allocate(indte(numa), stat=err)
217 if (err .ne. 0) then
218 alc_tab="INDTE"
219 goto 003
220 endif
221 if(allocated(savr)) deallocate(savr)
222 allocate(savr(taillc,numa,taillc), stat=err)
223 if (err .ne. 0) then
224 alc_tab="SAVR"
225 alc=.true.
226 goto 003
227 endif
228 if(allocated(tring)) deallocate(tring)
229 allocate(tring(taillc), stat=err)
230 if (err .ne. 0) then
231 alc_tab="TRING"
232 alc=.true.
233 goto 003
234 endif
235 if(allocated(the_chain)) deallocate(the_chain)
236 allocate(the_chain(taillc), stat=err)
237 if (err .ne. 0) then
238 alc_tab="THE_CHAIN"
239 alc=.true.
240 goto 003
241 endif
242
243 tring(:)=0
244 savr(:,:,:)=0
245 !$OMP DO SCHEDULE(STATIC,NA/NUMTH)
246 do j=1, na
247
248 if (tbr .or. alc) goto 002
249 if (tlt .eq. nsp+1 .or. lot(j) .eq. tlt) then
250
251 if ((isolated .and. cpat(j).eq.1) .or. (.not.isolated .and. (cpat(j).gt.0 .and. cpat(j).ne.2))) then
252
253 do l=1, cpat(j)
254
255 lora=lot(j)
256 lorb=lot(vpat(j,l))
257 if (aaaa) then
258 if (lora .ne. lorb) then
259 runsearch=.false.
260 else
261 runsearch=.true.
262 endif
263 else if (acac) then
264 if (lora .ne. lorb) then
265 runsearch=.true.
266 else
267 runsearch=.false.
268 endif
269 else if (nohp .and. lora.eq.lorb) then
270 runsearch=.false.
271 else
272 runsearch=.true.
273 endif
274
275 if (runsearch) then
276
277 rpat(:) = 0
278 do k=1, cpat(j)
279 rpat(vpat(j,k)) = 1
280 enddo
281 rpat(j)=1
282 the_chain(1)%ATOM=j
283 the_chain(1)%SPEC=lora
284 the_chain(1)%NEIGHBOR=1
285 the_chain(2)%ATOM=vpat(j,l)
286 the_chain(2)%SPEC=lorb
287 the_chain(2)%NEIGHBOR=cpat(vpat(j,l))
288 res_list(:) = 0
289 indte(:) = 0
290 taille=0
291 res = check_chain(the_chain, 2, taille, savr, tring, indte, res_list)
292 if (alc) alc_tab="CHECK_CHAIN"
293 if (tbr .or. alc) goto 002
294 if (cpat(vpat(j,l)) .eq. 2) then
295 call inside_chain (the_chain, 2, taille, lora, lorb, rpat, savr, tring, indte, res_list, cpat, vpat)
296 if (alc) alc_tab="INSIDE_CHAIN"
297 endif
298 if (tbr .or. alc) goto 002
299
300 endif
301 enddo
302 endif
303 endif
304
305 002 continue
306 enddo
307 !$OMP END DO NOWAIT
308 if (tbr .or. alc) goto 003
309 !$OMP CRITICAL
310 do k=2, taillc
311 if (tring(k).gt.0) then
312 if (nring(k,i).gt.0) then
313 o = 0
314 do l=1, tring(k)
315 do m=1, nring(k,i)
316 saut=.true.
317 do n=1, k
318 if (savring(k,m,n) .ne. savr(k,l,n)) then
319 saut=.false.
320 exit
321 endif
322 enddo
323 if (.not.saut) then
324 saut=.true.
325 do n=1, k
326 if (savring(k,m,k-n+1) .ne. savr(k,l,n)) then
327 saut=.false.
328 exit
329 endif
330 enddo
331 endif
332 if (saut) exit
333 enddo
334 if (.not.saut) then
335 o = o + 1
336 if (nring(k,i)+o .gt. numa) then
337 tbr=.true.
338 goto 004
339 endif
340 do m=1, k
341 savring(k,nring(k,i)+o,m) = savr(k,l,m)
342 enddo
343 endif
344 enddo
345 nring(k,i)=nring(k,i)+o
346 else
347 do l=1, tring(k)
348 do m=1, k
349 savring(k,l,m) = savr(k,l,m)
350 enddo
351 enddo
352 nring(k,i) = tring(k)
353 endif
354 endif
355 enddo
356
357 004 continue
358 !$OMP END CRITICAL
359
360 003 continue
361
362 if (allocated(rpat)) deallocate (rpat)
363 if (allocated(res_list)) deallocate (res_list)
364 if (allocated(indte)) deallocate (indte)
365 if (allocated(tring)) deallocate (tring)
366 if (allocated(savr)) deallocate (savr)
367 if (allocated(the_chain)) deallocate (the_chain)
368 !$OMP END PARALLEL
369 if (alc .or. tbr) goto 001
370
371 !do j=2, TAILLC
372 ! write (6, '("s= ",i4,", j= ",i2,", nr(",i2,",",i4,")= ",i2)') i,j,j,i, NRING(j,i)
373 ! if (NRING(j,i) .gt. 0) then
374 ! do k=1, NRING(j,i)
375 ! write (6, *) " k= ",k,", R(o)= ",SAVRING(j,k,1:j)
376 ! enddo
377 ! endif
378 !enddo
379 ch = ch + chains_to_ogl(i, nring, savring)
380
381enddo
382
383001 continue
384
385if (alc) then
386 call show_error ("Impossible to allocate memory"//char(0), &
387 "Subroutine: CHAINS_SEARCH_ATOMS"//char(0), "Table: "//alc_tab(1:len_trim(alc_tab))//char(0))
388endif
389
390if (allocated(cpat)) deallocate (cpat)
391if (allocated(vpat)) deallocate (vpat)
392if (allocated(savring)) deallocate (savring)
393
394if (ch .eq. ns) ch = chains_to_ogl_menu(nring)
395
396END SUBROUTINE
397#endif
398
399#ifdef OPENMP
400SUBROUTINE chains_search_steps (NUMTH)
401
402USE parameters
403!$ USE OMP_LIB
404IMPLICIT NONE
405INTEGER, INTENT(IN) :: numth
406#else
407SUBROUTINE chains_search_steps ()
408
409USE parameters
410IMPLICIT NONE
411#endif
412TYPE (RING), DIMENSION(:), ALLOCATABLE :: THE_CHAIN
413INTEGER, DIMENSION(:), ALLOCATABLE :: TRING, INDTE
414INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: SAVRING
415INTEGER :: RES, LORA, LORB, ch
416
417INTERFACE
418 INTEGER FUNCTION check_chain (THE_CHAIN, CHAINE, TAE, RSAVED, TRING, INDE, RESL)
419 USE parameters
420 TYPE (RING), DIMENSION(TAILLC), INTENT(IN) :: THE_CHAIN
421 INTEGER, INTENT(IN) :: CHAINE
422 INTEGER, INTENT(INOUT) :: TAE
423 INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: RSAVED
424 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: TRING
425 INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: INDE
426 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: RESL
427 END FUNCTION
428 RECURSIVE SUBROUTINE inside_chain (THE_CHAIN, CID, TAE, LRA, LRB, NRPAT, RSAVED, TRING, INDE, RESL, CPT, VPT)
429 USE parameters
430 TYPE (RING), DIMENSION(TAILLC), INTENT(INOUT) :: THE_CHAIN
431 INTEGER, INTENT(IN) :: CID, LRA, LRB
432 INTEGER, INTENT(INOUT) :: TAE
433 INTEGER, DIMENSION(NA), INTENT(INOUT) :: NRPAT
434 INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: RSAVED
435 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: TRING
436 INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: INDE
437 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: RESL
438 INTEGER, DIMENSION(NA), INTENT(IN):: CPT
439 INTEGER, DIMENSION(NA,MAXN), INTENT(IN) :: VPT
440 END SUBROUTINE
441 INTEGER FUNCTION chains_to_ogl (STEP, NRI, RSAVED)
442 USE parameters
443 INTEGER, INTENT(IN) :: STEP
444 INTEGER, DIMENSION(TAILLC, NS), INTENT(IN) :: NRI
445 INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(IN) :: RSAVED
446 END FUNCTION
447 INTEGER FUNCTION chains_to_ogl_menu (NRI)
448 USE parameters
449 INTEGER, DIMENSION(TAILLC, NS), INTENT(IN) :: NRI
450 END FUNCTION
451END INTERFACE
452
453ch = 0
454
455if (allocated(nring)) deallocate(nring)
456allocate(nring(taillc,ns), stat=err)
457if (err .ne. 0) then
458 alc_tab="NRING"
459 alc=.true.
460 goto 001
461endif
462nring(:,:) = 0
463
464#ifdef OPENMP
465! OpenMP on steps only
466!$OMP PARALLEL NUM_THREADS(NUMTH) DEFAULT (NONE) &
467!$OMP& PRIVATE(THE_CHAIN, RPAT, RUNSEARCH, ERR, SAVRING, TRING, INDTE, &
468!$OMP& j, k, l, m, n, o, LORA, LORB, RES, RES_LIST, CPAT, VPAT, TAILLE) &
469!$OMP& SHARED(i, p, NUMTH, NS, NA, TLT, NSP, LOT, ISOLATED, CONTJ, VOISJ, &
470!$OMP& NUMA, MAXN, ACAC, AAAA, NOHP, TAILLC, TBR, ALC, ALC_TAB, NCELLS, PBC, NRING, ch)
471#endif
472
473if(allocated(savring)) deallocate(savring)
474allocate(savring(taillc,numa,taillc), stat=err)
475if (err .ne. 0) then
476 alc_tab="SAVRING"
477 alc=.true.
478 goto 002
479endif
480if(allocated(cpat)) deallocate(cpat)
481allocate(cpat(na), stat=err)
482if (err .ne. 0) then
483 alc_tab="CPAT"
484 alc=.true.
485 goto 002
486endif
487 if(allocated(vpat)) deallocate(vpat)
488allocate(vpat(na,maxn), stat=err)
489if (err .ne. 0) then
490 alc_tab="VPAT"
491 alc=.true.
492 goto 002
493endif
494if (allocated(rpat)) deallocate(rpat)
495allocate(rpat(na), stat=err)
496if (err .ne. 0) then
497 alc_tab="RPAT"
498 alc=.true.
499 goto 002
500endif
501if(allocated(res_list)) deallocate(res_list)
502allocate(res_list(taillc), stat=err)
503if (err .ne. 0) then
504 alc_tab="REST_LIST"
505 alc=.true.
506 goto 002
507endif
508if(allocated(indte)) deallocate(indte)
509allocate(indte(numa), stat=err)
510if (err .ne. 0) then
511 alc_tab="INDTE"
512 goto 002
513endif
514if(allocated(tring)) deallocate(tring)
515allocate(tring(taillc), stat=err)
516if (err .ne. 0) then
517 alc_tab="TRING"
518 alc=.true.
519 goto 002
520endif
521if(allocated(the_chain)) deallocate(the_chain)
522allocate(the_chain(taillc), stat=err)
523if (err .ne. 0) then
524 alc_tab="THE_CHAIN"
525 alc=.true.
526 goto 002
527endif
528
529#ifdef OPENMP
530!$OMP DO SCHEDULE(STATIC,NS/NUMTH)
531#endif
532do i=1, ns
533
534 if (tbr .or. alc) goto 003
535 savring(:,:,:)=0
536 tring(:)=0
537 call setup_cpat_vpat_chain (contj, voisj, i, cpat, vpat)
538
539 do j=1, na
540
541 if (tlt .eq. nsp+1 .or. lot(j) .eq. tlt) then
542
543 if ((isolated .and. cpat(j).eq.1) .or. (.not.isolated .and. (cpat(j).gt.0 .and. cpat(j).ne.2))) then
544
545 do l=1, cpat(j)
546
547 lora=lot(j)
548 lorb=lot(vpat(j,l))
549 if (aaaa) then
550 if (lora .ne. lorb) then
551 runsearch=.false.
552 else
553 runsearch=.true.
554 endif
555 else if (acac) then
556 if (lora .ne. lorb) then
557 runsearch=.true.
558 else
559 runsearch=.false.
560 endif
561 else if (nohp .and. lora.eq.lorb) then
562 runsearch=.false.
563 else
564 runsearch=.true.
565 endif
566
567 if (runsearch) then
568
569 rpat(:) = 0
570 do k=1, cpat(j)
571 rpat(vpat(j,k)) = 1
572 enddo
573 rpat(j)=1
574 the_chain(1)%ATOM=j
575 the_chain(1)%SPEC=lora
576 the_chain(1)%NEIGHBOR=1
577 the_chain(2)%ATOM=vpat(j,l)
578 the_chain(2)%SPEC=lorb
579 the_chain(2)%NEIGHBOR=cpat(vpat(j,l))
580 res_list(:) = 0
581 indte(:) = 0
582 taille = 0
583 res = check_chain(the_chain, 2, taille, savring, tring, indte, res_list)
584 if (alc) alc_tab="CHECK_CHAIN"
585 if (tbr .or. alc) goto 003
586 if (cpat(vpat(j,l)) .eq. 2) then
587 call inside_chain (the_chain, 2, taille, lora, lorb, rpat, savring, tring, indte, res_list, cpat, vpat)
588 if (alc) alc_tab="INSIDE_CHAIN"
589 endif
590 if (tbr .or. alc) goto 003
591
592 endif
593 enddo
594 endif
595 endif
596
597 enddo
598
599 do j=1, taillc
600 nring(j,i) = tring(j)
601 enddo
602
603 !do j=2, TAILLC
604 ! write (6, '("s= ",i4,", j= ",i2,", nr(",i2,",",i4,")= ",i2)') i,j,j,i, NRING(j,i)
605 ! if (NRING(j,i) .gt. 0) then
606 ! do k=1, NRING(j,i)
607 ! write (6, *) " k= ",k,", R(o)= ",SAVRING(j,k,1:j)
608 ! enddo
609 ! endif
610 !enddo
611
612 j = chains_to_ogl(i, nring, savring)
613#ifdef OPENMP
614 !$OMP ATOMIC
615#endif
616 ch = ch + j
617
618 003 continue
619
620enddo
621#ifdef OPENMP
622!$OMP END DO NOWAIT
623#endif
624
625002 continue
626
627if (alc) then
628 call show_error ("Impossible to allocate memory"//char(0), &
629 "Subroutine: CHAINS_SEARCH_STEPS"//char(0), "Table: "//alc_tab(1:len_trim(alc_tab))//char(0))
630endif
631
632if (allocated(tring)) deallocate (tring)
633if (allocated(the_chain)) deallocate (the_chain)
634if (allocated(savring)) deallocate (savring)
635if (allocated(cpat)) deallocate (cpat)
636if (allocated(vpat)) deallocate (vpat)
637if (allocated(rpat)) deallocate (rpat)
638if (allocated(res_list)) deallocate (res_list)
639if (allocated(indte)) deallocate (indte)
640
641#ifdef OPENMP
642!$OMP END PARALLEL
643#endif
644
645if (ch .eq. ns) ch = chains_to_ogl_menu(nring)
646
647001 continue
648
649END SUBROUTINE
650
651INTEGER FUNCTION check_chain (THE_CHAIN, CHAINE, TAE, RSAVED, TRING, INDE, RESL)
652
653USE parameters
654
655IMPLICIT NONE
656
657TYPE (ring), DIMENSION(TAILLC), INTENT(IN) :: the_chain
658INTEGER, INTENT(IN) :: chaine
659INTEGER, INTENT(INOUT) :: tae
660INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: rsaved
661INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: tring
662INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: inde
663INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: resl
664INTERFACE
665 SUBROUTINE save_this_chain (THE_CHAIN, TLES, RSAVED, TRING, INDT, RESL)
666 USE parameters
667 TYPE (ring), DIMENSION(TAILLC), INTENT(IN) :: the_chain
668 INTEGER, INTENT(IN) :: tles
669 INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: rsaved
670 INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: indt
671 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: resl, tring
672 END SUBROUTINE
673 SUBROUTINE del_this_chain (TLED, RSAVED, TRING, RESL, INDT)
674 USE parameters
675 INTEGER, INTENT(IN) :: tled
676 INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: rsaved
677 INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: indt
678 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: resl, tring
679 END
680END INTERFACE
681
682 check_chain = 0
683 if (chaine .ge. tae .and. chaine .le. taillc) then
684 if (tae .gt. 0) call del_this_chain (tae, rsaved, tring, resl, inde)
685 tae=chaine
686 call save_this_chain (the_chain, tae, rsaved, tring, inde, resl)
687 if (tbr .or. alc) check_chain = 1
688 endif
689
690END FUNCTION
691
692RECURSIVE SUBROUTINE inside_chain (THE_CHAIN, CID, TAE, LRA, LRB, &
693 NRPAT, RSAVED, TRING, INDE, RESL, CPT, VPT)
694USE parameters
695
696IMPLICIT NONE
697
698TYPE (ring), DIMENSION(TAILLC), INTENT(INOUT) :: the_chain
699INTEGER, INTENT(IN) :: cid, lra, lrb
700INTEGER, INTENT(INOUT) :: tae
701INTEGER, DIMENSION(NA), INTENT(INOUT) :: nrpat
702INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: rsaved
703INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: tring
704INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: inde
705INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: resl
706INTEGER, DIMENSION(NA), INTENT(IN):: cpt
707INTEGER, DIMENSION(NA,MAXN), INTENT(IN) :: vpt
708INTEGER :: ind, res
709LOGICAL :: addsp
710
711INTERFACE
712 INTEGER FUNCTION check_chain (THE_CHAIN, CHAINE, TAE, RSAVED, TRING, INDE, RESL)
713 USE parameters
714 TYPE (ring), DIMENSION(TAILLC), INTENT(IN) :: the_chain
715 INTEGER, INTENT(IN) :: chaine
716 INTEGER, INTENT(INOUT) :: tae
717 INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: rsaved
718 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: tring
719 INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: inde
720 INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: resl
721 END FUNCTION
722END INTERFACE
723
724if (cid-1 .lt. taillc) then
725
726 do while (the_chain(cid)%NEIGHBOR .ge. 1)
727
728 ind = vpt(the_chain(cid)%ATOM, the_chain(cid)%NEIGHBOR)
729 if (nrpat(ind).eq.0 .and. cpt(ind).ge.1) then
730
731 if (aaaa) then
732 if (the_chain(cid)%SPEC .eq. lot(ind)) then
733 addsp=.true.
734 else
735 addsp=.false.
736 endif
737 else if (acac) then
738 if (mod(cid,2).ne.0 .and. lot(ind).eq.lrb) then
739 addsp=.true.
740 else if (mod(cid,2).eq.0 .and. lot(ind).eq.lra) then
741 addsp=.true.
742 else
743 addsp=.false.
744 endif
745 else if (nohp .and. the_chain(cid)%SPEC.eq.lot(ind)) then
746 addsp=.false.
747 else
748 addsp=.true.
749 endif
750
751 if (addsp .and. ((isolated .and. cpt(ind).le.2) .or. .not.isolated)) then
752 the_chain(cid+1)%ATOM = ind
753 the_chain(cid+1)%SPEC = lot(ind)
754 the_chain(cid+1)%NEIGHBOR = cpt(ind)
755 nrpat(ind)=1
756 res = check_chain(the_chain, cid+1, tae, rsaved, tring, inde, resl)
757 if (tbr .or. alc) goto 001
758 if (res.eq.0 .and. cpt(ind).eq.2) then
759 call inside_chain(the_chain, cid+1, tae, lra, lrb, nrpat, rsaved, tring, inde, resl, cpt, vpt)
760 if (tbr .or. alc) goto 001
761 endif
762 nrpat(ind) = 0
763 endif
764
765 endif
766 the_chain(cid)%NEIGHBOR = the_chain(cid)%NEIGHBOR - 1
767
768 enddo
769
770endif
771
772001 continue
773
774END SUBROUTINE inside_chain
775
776SUBROUTINE save_this_chain (THE_CHAIN, TLES, RSAVED, TRING, INDT, RESL)
777
778USE parameters
779
780IMPLICIT NONE
781
782TYPE (RING), DIMENSION(TAILLC), INTENT(IN) :: THE_CHAIN
783INTEGER, INTENT(IN) :: TLES
784INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: RSAVED
785INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: INDT
786INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: RESL, TRING
787INTEGER :: idx, idy
788LOGICAL :: NEWCHAIN
789INTEGER, DIMENSION(TLES) :: TOSAV
790
791! A ring has been found, we need to check if it has already been found or not
792
793do idx=1, tles
794
795! Creation of two tab first for the numerical sorting of the list
796! The other without sorting for output
797 tosav(idx)=the_chain(idx)%ATOM
798
799enddo
800
801if (tring(tles) .ne. 0) then
802
803 do idx=1, tring(tles)
804! do-loop on existing rings to check if the new on has already been found
805
806 newchain=.false.
807
808 do idy=1, tles
809 if (tosav(idy) .ne. rsaved(tles,idx,idy)) then
810 newchain=.true.
811 exit
812 endif
813 enddo
814
815 if (newchain) then
816 newchain=.false.
817 do idy=1, tles
818 if (tosav(tles-idy+1) .ne. rsaved(tles,idx,idy)) then
819 newchain=.true.
820 exit
821 endif
822 enddo
823 endif
824
825 if (.not.newchain) then
826
827 ! Already been found n-times, increment of the counter
828 indt(idx)=indt(idx)+1
829 exit
830
831 endif
832
833 enddo
834
835else
836
837 newchain=.true.
838
839endif
840
841if (newchain) then
842 resl(tles)=resl(tles)+1
843 tring(tles)=tring(tles)+1
844 if (tring(tles) .gt. numa) then
845 tbr=.true.
846 goto 001
847 endif
848 indt(tring(tles))=indt(tring(tles))+1
849 do idx=1, tles
850 rsaved(tles,tring(tles),idx)=tosav(idx)
851 enddo
852endif
853
854001 continue
855
856END SUBROUTINE
857
858SUBROUTINE del_this_chain (TLED, RSAVED, TRING, RESL, INDT)
859
860USE parameters
861
862IMPLICIT NONE
863
864INTEGER, INTENT(IN) :: TLED
865INTEGER, DIMENSION(TAILLC,NUMA,TAILLC), INTENT(INOUT) :: RSAVED
866INTEGER, DIMENSION(NUMA), INTENT(INOUT) :: INDT
867INTEGER, DIMENSION(TAILLC), INTENT(INOUT) :: RESL, TRING
868INTEGER :: xdel, did
869
870! The max size of the ring possible for the triplet N1-At-N2 has down
871! We have to delete the bigger rings already found for this triplet
872if (resl(tled) .ge. 1) then
873
874 do xdel=0, resl(tled)-1
875
876 do did=1, taillc
877 rsaved(tled,tring(tled)-xdel,did)=0
878 enddo
879 indt(:) = 0
880
881 enddo
882
883 tring(tled)=tring(tled)-resl(tled)
884 resl(tled)=0
885
886endif
887
888END SUBROUTINE
check_chain
integer function check_chain(the_chain, chaine, tae, rsaved, tring, inde, resl)
Definition chains.F90:652
save_this_chain
subroutine save_this_chain(the_chain, tles, rsaved, tring, indt, resl)
Definition chains.F90:777
chains
integer function chains()
Definition chains.F90:54
del_this_chain
subroutine del_this_chain(tled, rsaved, tring, resl, indt)
Definition chains.F90:859
setup_cpat_vpat_chain
subroutine setup_cpat_vpat_chain(cont, vois, str, cpt, vpt)
Definition chains.F90:22
inside_chain
recursive subroutine inside_chain(the_chain, cid, tae, lra, lrb, nrpat, rsaved, tring, inde, resl, cpt, vpt)
Definition chains.F90:694
chains_search_steps
subroutine chains_search_steps()
Definition chains.F90:408
chains_to_ogl_menu
integer function chains_to_ogl_menu(nri)
Definition chains_ogl.F90:102
chains_to_ogl
integer function chains_to_ogl(step, nri, rsaved)
Definition chains_ogl.F90:22
rechains
integer function rechains()
Definition initchains.F90:69
show_error
void show_error(char *error, int val, GtkWidget *win)
show error message
Definition interface.c:293
parameters::taillc
integer taillc
Definition parameters.F90:152
parameters::tbr
logical tbr
Definition parameters.F90:108
parameters::numa
integer numa
Definition parameters.F90:136