source: trunk/AGRIF/AGRIF_FILES/modcluster.F @ 396

Last change on this file since 396 was 396, checked in by opalod, 15 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 47.6 KB
Line 
1!
2! $Id$
3!
4C     AGRIF (Adaptive Grid Refinement In Fortran)
5C
6C     Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
7C                        Christophe Vouland (Christophe.Vouland@imag.fr)   
8C
9C     This program is free software; you can redistribute it and/or modify
10C     it under the terms of the GNU General Public License as published by
11C     the Free Software Foundation; either version 2 of the License, or
12C     (at your option) any later version.
13C
14C     This program is distributed in the hope that it will be useful,
15C     but WITHOUT ANY WARRANTY; without even the implied warranty of
16C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17C     GNU General Public License for more details.
18C
19C     You should have received a copy of the GNU General Public License
20C     along with this program; if not, write to the Free Software
21C     Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
22C
23C
24C
25CCC   Module AGRIF_Clustering 
26C
27C
28      Module Agrif_Clustering 
29C
30CCC   Description:
31CCC   Module to create and initialize the grid hierarchy from the 
32CCC   AGRIF_FixedGrids.in file.
33C
34C     Modules used:
35C 
36      Use Agrif_Curgridfunctions 
37      Use Agrif_Init_Vars
38      Use Agrif_Save
39C             
40      IMPLICIT NONE
41C       
42      Contains
43C     Define procedures contained in this module
44C
45C
46C
47C     **************************************************************************
48CCC   Subroutine Agrif_Cluster_All 
49C     **************************************************************************
50C
51      Recursive Subroutine Agrif_Cluster_All(g,coarsegrid)
52C
53CCC   Description:
54CCC   Subroutine for the clustering. A temporary grid hierarchy, pointed by 
55CCC   coarsegrid, is created.
56C
57CC    Method:
58CC           
59C
60C     Declarations:
61C
62C     Pointer arguments   
63      TYPE(AGRIF_grid)     ,pointer   :: g        ! Pointer on the current grid
64      TYPE(AGRIF_rectangle),pointer   :: coarsegrid
65C     
66C     Local pointer         
67      TYPE(AGRIF_lrectangle),pointer  :: parcours 
68      TYPE(AGRIF_grid)      ,pointer  :: newgrid 
69      REAL                            :: g_eps
70      INTEGER                         :: iii
71C     
72      g_eps = huge(1.)
73      do iii = 1 , Agrif_Probdim
74         g_eps = min(g_eps,g%Agrif_d(iii))
75      enddo
76C
77      g_eps = g_eps/100.                 
78C
79C     Necessary condition for clustering 
80      do iii = 1 , Agrif_Probdim
81         if (g%Agrif_d(iii)/Agrif_coeffref(iii).LT.
82     &                   (Agrif_mind(iii)-g_eps)) Return
83      enddo
84C
85      Nullify(coarsegrid%childgrids)
86C
87      Call Agrif_ClusterGridnD(g,coarsegrid) 
88C
89      parcours => coarsegrid % childgrids                   
90C     
91      do while (associated(parcours))
92C     
93C       Newgrid is created. It is a copy of a fine grid created previously by
94C          clustering.     
95        Allocate(newgrid)
96C     
97        Nullify(newgrid%child_grids)
98C
99        do iii = 1 , Agrif_Probdim
100           newgrid % nb(iii) = (parcours % r % imax(iii) - 
101     &                          parcours % r % imin(iii)) *
102     &                          Agrif_Coeffref(iii)
103C       
104           newgrid % Agrif_x(iii) = g%Agrif_x(iii) + 
105     &                         (parcours %r % imin(iii) -1) 
106     &                         *g%Agrif_d(iii)
107C 
108           newgrid % Agrif_d(iii) = g%Agrif_d(iii) / Agrif_Coeffref(iii)
109C
110        enddo
111C
112        if ( Agrif_Probdim .EQ. 1 ) then
113           allocate(newgrid%tabpoint1D(newgrid%nb(1)+1))
114           newgrid%tabpoint1D = 0
115        endif
116C
117        if ( Agrif_Probdim .EQ. 2 ) then
118           allocate(newgrid%tabpoint2D(newgrid%nb(1)+1,
119     &                                 newgrid%nb(2)+1))
120           newgrid%tabpoint2D = 0     
121        endif
122C
123        if ( Agrif_Probdim .EQ. 3 ) then
124           allocate(newgrid%tabpoint3D(newgrid%nb(1)+1,
125     &                                 newgrid%nb(2)+1,
126     &                                 newgrid%nb(3)+1))
127           newgrid%tabpoint3D = 0
128        endif
129C       Points detection on newgrid
130        Call Agrif_TabpointsnD(Agrif_mygrid,newgrid) 
131C
132C       Recursive call to Agrif_Cluster_All           
133        Call Agrif_Cluster_All (newgrid, parcours % r)       
134C
135        parcours => parcours % next 
136C     
137        if ( Agrif_Probdim .EQ. 1 ) Deallocate(newgrid%tabpoint1D)
138        if ( Agrif_Probdim .EQ. 2 ) Deallocate(newgrid%tabpoint2D)
139        if ( Agrif_Probdim .EQ. 3 ) Deallocate(newgrid%tabpoint3D)
140C
141        Deallocate(newgrid)   
142C
143      enddo
144C
145C     
146      End Subroutine Agrif_Cluster_All
147C
148C     **************************************************************************
149CCC   Subroutine Agrif_TabpointsnD
150C     **************************************************************************
151C
152      Recursive Subroutine Agrif_TabpointsnD(g,newgrid)
153C
154CCC   Description:
155CCC   Copy on newgrid of points detected on the grid hierarchy pointed by g.   
156C
157CC    Method:
158CC           
159C
160C     Declarations:
161C
162C     Arguments
163      TYPE(Agrif_Grid),pointer   :: g,newgrid
164C
165C     Local variables     
166      TYPE(Agrif_Pgrid),pointer  :: parcours
167C
168      REAL                  :: g_eps,newgrid_eps,eps
169      REAL   , DIMENSION(3) :: newmin,newmax
170      REAL   , DIMENSION(3) :: gmin,gmax
171      REAL   , DIMENSION(3) :: xmin
172      INTEGER, DIMENSION(3) :: igmin,inewmin
173      INTEGER, DIMENSION(3) :: inewmax
174      INTEGER               :: iii
175      INTEGER               :: i,j,k
176      INTEGER               :: i0,j0,k0
177C
178C     
179      parcours => g % child_grids
180C
181      do While(associated(parcours))
182        Call Agrif_TabpointsnD(parcours%gr,newgrid)
183        parcours => parcours % next
184      enddo     
185C
186      g_eps = 10.
187      newgrid_eps = 10.
188C     
189      do iii = 1 , Agrif_probdim
190         g_eps = min( g_eps , g % Agrif_d(iii) )
191         newgrid_eps = min(newgrid_eps,newgrid%Agrif_d(iii))
192      enddo
193C
194      eps = min(g_eps,newgrid_eps)/100.                 
195C                   
196      do iii = 1 , Agrif_probdim
197         if (newgrid%Agrif_d(iii) .LT. (g%Agrif_d(iii)-eps)) Return
198C                   
199         gmin(iii) = g%Agrif_x(iii)
200         gmax(iii) = g%Agrif_x(iii) + g%nb(iii) * g%Agrif_d(iii)
201C 
202         newmin(iii) = newgrid%Agrif_x(iii)
203         newmax(iii) = newgrid%Agrif_x(iii) + newgrid%nb(iii) *
204     &                 newgrid%Agrif_d(iii)
205C     
206         if (gmax(iii) .LT. newmin(iii)) Return
207C
208         if (gmin(iii) .GT. newmax(iii)) Return
209C           
210         inewmin(iii) = 1 - floor(-(max(gmin(iii),newmin(iii))-
211     &                    newmin(iii))
212     &                   /newgrid%Agrif_d(iii)) 
213C         
214         xmin(iii) = newgrid%Agrif_x(iii) + (inewmin(iii)-1)*
215     &              newgrid%Agrif_d(iii)         
216C       
217         igmin(iii) = 1 + nint((xmin(iii)-gmin(iii))/g%Agrif_d(iii))
218C
219         inewmax(iii) = 1 + int((min(gmax(iii),newmax(iii))-
220     &                  newmin(iii))/newgrid%Agrif_d(iii))
221      enddo
222C               
223      if ( Agrif_probdim .EQ. 1 ) then
224         i0 = igmin(1)
225         do i = inewmin(1),inewmax(1)
226            newgrid%tabpoint1D(i) = max(
227     &                           newgrid%tabpoint1D(i),
228     &                           g%tabpoint1D(i0))
229         enddo
230         i0 = i0 + int(newgrid%Agrif_d(1)/g%Agrif_d(1))
231      endif
232C
233      if ( Agrif_probdim .EQ. 2 ) then
234         i0 = igmin(1)
235         do i = inewmin(1),inewmax(1)
236            j0 = igmin(2)
237            do j = inewmin(2),inewmax(2)
238               newgrid%tabpoint2D(i,j) = max(
239     &                           newgrid%tabpoint2D(i,j),
240     &                           g%tabpoint2D(i0,j0))
241               j0 = j0 + int(newgrid%Agrif_d(2)/g%Agrif_d(2))
242            enddo
243            i0 = i0 + int(newgrid%Agrif_d(1)/g%Agrif_d(1))
244         enddo
245      endif
246C
247      if ( Agrif_probdim .EQ. 3 ) then
248         i0 = igmin(1)
249         do i = inewmin(1),inewmax(1)
250            j0 = igmin(2)
251            do j = inewmin(2),inewmax(2)
252               k0 = igmin(3)
253               do k = inewmin(3),inewmax(3)
254                  newgrid%tabpoint3D(i,j,k) = max(
255     &                           newgrid%tabpoint3D(i,j,k),
256     &                           g%tabpoint3D(i0,j0,k0))
257                  k0 = k0 + int(newgrid%Agrif_d(3)/g%Agrif_d(3))
258               enddo                                       
259               j0 = j0 + int(newgrid%Agrif_d(2)/g%Agrif_d(2))
260            enddo
261            i0 = i0 + int(newgrid%Agrif_d(1)/g%Agrif_d(1))
262         enddo
263      endif
264C
265      Return
266C
267C
268      End Subroutine Agrif_TabpointsnD
269C
270C     **************************************************************************
271CCC   Subroutine Agrif_ClusterGridnD
272C     **************************************************************************
273C     
274      Subroutine Agrif_ClusterGridnD(g,coarsegrid)
275C
276CCC   Description:
277CCC   Clustering on the grid pointed by g.
278C
279CC    Method:
280CC           
281C
282C     Declarations:
283C
284C     Pointer arguments
285      TYPE(AGRIF_grid)     ,pointer  :: g          ! Pointer on the current grid
286      TYPE(AGRIF_rectangle),pointer  :: coarsegrid
287C
288C     Local variables     
289      TYPE(Agrif_rectangle) :: newrect
290      TYPE(Agrif_Variable)  :: newflag
291C
292      INTEGER               :: i,j,k
293      INTEGER ,DIMENSION(3) :: sx
294      INTEGER               :: bufferwidth,flagpoints
295      INTEGER               :: n1,n2,m1,m2,o1,o2
296      INTEGER               :: iii
297C
298C     
299      bufferwidth = int(Agrif_Minwidth/5.)
300C     
301      do iii = 1 , Agrif_probdim
302         sx(iii) = g % nb(iii) + 1
303      enddo
304C                 
305      if ( Agrif_probdim .EQ. 1 ) then
306         allocate(newflag%iarray1(sx(1)))
307         newflag%iarray1 = 0     
308      endif
309      if ( Agrif_probdim .EQ. 2 ) then
310         allocate(newflag%iarray2(sx(1),sx(2)))
311         newflag%iarray2 = 0     
312      endif
313      if ( Agrif_probdim .EQ. 3 ) then
314         allocate(newflag%iarray3(sx(1),sx(2),sx(3)))
315         newflag%iarray3 = 0     
316      endif
317C
318      flagpoints = 0 
319C     
320      if (bufferwidth>0) then
321C     
322         if ( Agrif_probdim .EQ. 1 ) then
323            do i = bufferwidth,sx(1)-bufferwidth+1     
324               if (g % tabpoint1D(i) .EQ. 1) then
325                  m1 = i - bufferwidth + 1
326                  m2 = i + bufferwidth - 1                 
327                  flagpoints = flagpoints + 1
328                  newflag%iarray1(m1:m2)=1 
329               endif
330            enddo   
331         endif
332C
333        if ( Agrif_probdim .EQ. 2 ) then
334           do i = bufferwidth,sx(1)-bufferwidth+1     
335               do j = bufferwidth,sx(2)-bufferwidth+1
336                  if (g % tabpoint2D(i,j) .EQ. 1) then
337                     n1 = j - bufferwidth + 1
338                     n2 = j + bufferwidth - 1
339                     m1 = i - bufferwidth + 1
340                     m2 = i + bufferwidth - 1                 
341                     flagpoints = flagpoints + 1
342                     newflag%iarray2(m1:m2,n1:n2)=1 
343                  endif 
344               enddo   
345            enddo
346         endif
347C
348        if ( Agrif_probdim .EQ. 3 ) then
349            do i = bufferwidth,sx(1)-bufferwidth+1     
350               do j = bufferwidth,sx(2)-bufferwidth+1
351                  do k = bufferwidth,sx(3)-bufferwidth+1
352                     if (g % tabpoint3D(i,j,k) .EQ. 1) then
353                        o1 = k - bufferwidth + 1
354                        o2 = k + bufferwidth - 1
355                        n1 = j - bufferwidth + 1
356                        n2 = j + bufferwidth - 1
357                        m1 = i - bufferwidth + 1
358                        m2 = i + bufferwidth - 1                 
359                        flagpoints = flagpoints + 1
360                        newflag%iarray3(m1:m2,n1:n2,o1:o2)=1 
361                     endif
362                  enddo 
363               enddo   
364            enddo
365        endif
366      else
367          flagpoints = 1       
368C
369          if ( Agrif_probdim .EQ. 1 ) then
370          newflag%iarray1 = g % tabpoint1D
371          endif
372          if ( Agrif_probdim .EQ. 2 ) then
373          newflag%iarray2 = g % tabpoint2D
374          endif
375          if ( Agrif_probdim .EQ. 3 ) then
376          newflag%iarray3 = g % tabpoint3D
377          endif
378      endif
379C       
380      if (flagpoints .EQ. 0) then       
381          if ( Agrif_probdim .EQ. 1 ) deallocate(newflag%iarray1) 
382          if ( Agrif_probdim .EQ. 2 ) deallocate(newflag%iarray2) 
383          if ( Agrif_probdim .EQ. 3 ) deallocate(newflag%iarray3) 
384          Return
385      endif       
386C     
387      do iii = 1 , Agrif_probdim
388         newrect % imin(iii) = 1
389         newrect % imax(iii) = sx(iii)
390      enddo
391C     
392      Call Agrif_Clusternd(newflag,
393     &                     coarsegrid%childgrids,newrect) 
394C     
395      if ( Agrif_probdim .EQ. 1 ) deallocate(newflag%iarray1)
396      if ( Agrif_probdim .EQ. 2 ) deallocate(newflag%iarray2)
397      if ( Agrif_probdim .EQ. 3 ) deallocate(newflag%iarray3)
398C 
399C   
400      End Subroutine Agrif_ClusterGridnD
401C
402C     **************************************************************************
403CCC   Subroutine Agrif_ClusternD
404C     **************************************************************************
405C
406      Recursive subroutine Agrif_Clusternd(flag,boxlib,oldB) 
407C
408CCC   Description:
409CCC   Clustering on the grid pointed by oldB.
410C
411CC    Method:
412CC           
413C
414C     Declarations:
415C
416C     Arguments 
417      TYPE(Agrif_rectangle) ::  oldB   
418      TYPE(Agrif_Variable)  :: flag
419c      INTEGER,DIMENSION(oldB%imin(1):oldB%imax(1),
420c     &                  oldB%imin(2):oldB%imax(2)) :: flag
421      TYPE(Agrif_lrectangle),pointer :: boxlib     
422C
423C     Local variables     
424      TYPE(Agrif_lrectangle),pointer :: tempbox,parcbox,parcbox2       
425      TYPE(Agrif_rectangle) :: newB,newB2
426      INTEGER :: i,j,k,iii
427      INTEGER,DIMENSION(:),allocatable :: i_sig 
428      INTEGER,DIMENSION(:),allocatable :: j_sig       
429      INTEGER,DIMENSION(:),allocatable :: k_sig       
430      INTEGER,DIMENSION(3) :: ipu,ipl
431      INTEGER,DIMENSION(3) :: istr,islice
432      REAL :: cureff
433      REAL :: neweff
434      INTEGER :: ValMax,ValSum,TailleTab
435      INTEGER :: nbpoints,nbpointsflag 
436      LOGICAL :: test
437C         
438      allocate(i_sig(oldB%imin(1):oldB%imax(1)))
439      if ( Agrif_probdim .GE. 2 ) 
440     & allocate(j_sig(oldB%imin(2):oldB%imax(2)))
441      if ( Agrif_probdim .EQ. 3 ) 
442     & allocate(k_sig(oldB%imin(3):oldB%imax(3)))
443C
444      test = .FALSE.
445      do iii = 1 , Agrif_probdim
446         test = test .OR. ( (oldB%imax(iii)-oldB%imin(iii)+1) 
447     &                    .LT. Agrif_Minwidth)
448      enddo
449      if ( test ) Return
450C     
451      if ( Agrif_probdim .EQ. 1 ) i_sig = flag%iarray1
452      if ( Agrif_probdim .EQ. 2 ) then
453         do i = oldB%imin(1),oldB%imax(1)
454           i_sig(i) = SUM(flag%iarray2(i,
455     &                            oldB%imin(2):oldB%imax(2)))
456         enddo
457         do j = oldB%imin(2),oldB%imax(2)
458           j_sig(j) = SUM(flag%iarray2(
459     &                            oldB%imin(1):oldB%imax(1),j))
460         enddo     
461      endif
462      if ( Agrif_probdim .EQ. 3 ) then
463         do i = oldB%imin(1),oldB%imax(1)
464            i_sig(i) = SUM(flag%iarray3(i,
465     &                            oldB%imin(2):oldB%imax(2),
466     &                            oldB%imin(3):oldB%imax(3)))
467         enddo
468         do j = oldB%imin(2),oldB%imax(2)
469            j_sig(j) = SUM(flag%iarray3(
470     &                          oldB%imin(1):oldB%imax(1),j,
471     &                          oldB%imin(3):oldB%imax(3)))
472         enddo
473         do k = oldB%imin(3),oldB%imax(3)
474            k_sig(k) = SUM(flag%iarray3(
475     &                          oldB%imin(1):oldB%imax(1),
476     &                          oldB%imin(2):oldB%imax(2),k))
477         enddo     
478      endif
479C                   
480      do iii = 1 , Agrif_probdim
481         ipl(iii) = oldB%imin(iii)
482         ipu(iii) = oldB%imax(iii)
483      enddo
484C           
485      Call Agrif_Clusterprune(i_sig,ipl(1),ipu(1)) 
486      if ( Agrif_probdim .GE. 2 ) 
487     &   Call Agrif_Clusterprune(j_sig,ipl(2),ipu(2))     
488      if ( Agrif_probdim .EQ. 3 ) 
489     &   Call Agrif_Clusterprune(k_sig,ipl(3),ipu(3))     
490C     
491      test = .TRUE.
492      do iii = 1 , Agrif_probdim
493         test = test .AND. (ipl(iii).EQ.oldB%imin(iii))
494         test = test .AND. (ipu(iii).EQ.oldB%imax(iii))
495      enddo
496     
497      if (.NOT. test) then
498          do iii = 1 , Agrif_probdim
499             newB%imin(iii) = ipl(iii)
500             newB%imax(iii) = ipu(iii)
501          enddo
502C       
503          if ( Agrif_probdim .EQ. 1 ) 
504     &       nbpoints = SUM(flag%iarray1(newB%imin(1):newB%imax(1)))   
505          if ( Agrif_probdim .EQ. 2 ) 
506     &       nbpoints = SUM(flag%iarray2(newB%imin(1):newB%imax(1),
507     &                           newB%imin(2):newB%imax(2)))   
508          if ( Agrif_probdim .EQ. 3 ) 
509     &       nbpoints = SUM(flag%iarray3(newB%imin(1):newB%imax(1),
510     &                           newB%imin(2):newB%imax(2),   
511     &                           newB%imin(3):newB%imax(3)))
512C   
513          if ( Agrif_probdim .EQ. 1 ) 
514     &       TailleTab = newB%imax(1)-newB%imin(1)+1
515          if ( Agrif_probdim .EQ. 2 ) 
516     &       TailleTab = (newB%imax(1)-newB%imin(1)+1)*
517     &                   (newB%imax(2)-newB%imin(2)+1)
518          if ( Agrif_probdim .EQ. 3 ) 
519     &       TailleTab = (newB%imax(1)-newB%imin(1)+1)*
520     &                   (newB%imax(2)-newB%imin(2)+1)*
521     &                   (newB%imax(3)-newB%imin(3)+1)
522C
523          neweff = REAL(nbpoints)/TailleTab
524C     
525          if (nbpoints.GT.0) then
526C       
527              if ((neweff .GT .Agrif_efficiency)) then
528                  Call Agrif_Add_Rectangle(newB,boxlib)
529                  Return
530              else
531C           
532                  tempbox => boxlib
533                  newB2 = newB
534                  Call Agrif_Clusternd(flag,
535     &                      boxlib,newB)
536C     
537C                 Compute new efficiency
538C
539                  cureff = neweff
540                  parcbox2 => boxlib
541                  nbpoints = 0
542                  nbpointsflag = 0
543C
544                  do While (associated(parcbox2))
545                    if (associated(parcbox2,tempbox)) Exit
546                    newB = parcbox2%r
547C
548                    if ( Agrif_probdim .EQ. 1 ) Valsum = 
549     &                                 SUM(flag%iarray1(
550     &                                 newB%imin(1):newB%imax(1)))
551                    if ( Agrif_probdim .EQ. 2 ) Valsum = 
552     &                                 SUM(flag%iarray2(
553     &                                 newB%imin(1):newB%imax(1),
554     &                                 newB%imin(2):newB%imax(2)))
555                    if ( Agrif_probdim .EQ. 3 ) Valsum = 
556     &                                 SUM(flag%iarray3(
557     &                                 newB%imin(1):newB%imax(1),
558     &                                 newB%imin(2):newB%imax(2),
559     &                                 newB%imin(3):newB%imax(3)))
560C
561                    nbpointsflag = nbpointsflag + ValSum
562                    if ( Agrif_probdim .EQ. 1 ) 
563     &                 TailleTab = newB%imax(1)-newB%imin(1)+1
564                    if ( Agrif_probdim .EQ. 2 ) 
565     &                 TailleTab = (newB%imax(1)-newB%imin(1)+1)*
566     &                             (newB%imax(2)-newB%imin(2)+1)
567                    if ( Agrif_probdim .EQ. 3 ) 
568     &                 TailleTab = (newB%imax(1)-newB%imin(1)+1)*
569     &                             (newB%imax(2)-newB%imin(2)+1)*
570     &                             (newB%imax(3)-newB%imin(3)+1)
571                    nbpoints = nbpoints + TailleTab
572                    parcbox2 => parcbox2%next 
573                  enddo 
574C coefficient 1.05 avant 1.15 possibilité de laisser choix à l utilisateur
575                  if  (REAL(nbpointsflag)/REAL(nbpoints)
576     &                 .LT.(1.05*cureff)) then
577                      parcbox2 => boxlib           
578                      do While (associated(parcbox2))
579                        if (associated(parcbox2,tempbox)) Exit
580                        deallocate(parcbox2%r)
581                        parcbox2 => parcbox2%next             
582                      enddo     
583                      boxlib => tempbox
584                      Call Agrif_Add_Rectangle(newB2,boxlib)
585                      Return
586                  endif
587              endif         
588          endif
589          Return
590      endif
591C       
592      do iii = 1 , Agrif_Probdim
593         istr(iii) = oldB%imax(iii)
594         islice(iii) = oldB%imin(iii)
595      enddo     
596C     
597      Call Agrif_Clusterslice(i_sig,islice(1),istr(1)) 
598      if ( Agrif_probdim .GE. 2 ) 
599     & Call Agrif_Clusterslice(j_sig,islice(2),istr(2)) 
600      if ( Agrif_probdim .EQ. 3 ) 
601     & Call Agrif_Clusterslice(k_sig,islice(3),istr(3)) 
602C     
603      ValSum = 0
604      do iii = 1 , Agrif_Probdim
605         Valsum = valSum + islice(iii)
606      enddo
607C     
608      if ( Valsum .EQ. -Agrif_Probdim ) then
609          Call Agrif_Add_Rectangle(oldB,boxlib) 
610          Return
611      endif
612C       
613      nullify(tempbox)
614      tempbox => boxlib
615      if ( Agrif_probdim .EQ. 1 ) 
616     &      cureff  = oldB%imax(1)-oldB%imin(1)+1
617      if ( Agrif_probdim .EQ. 2 ) 
618     &      cureff  = (oldB%imax(1)-oldB%imin(1)+1)*
619     &                (oldB%imax(2)-oldB%imin(2)+1)
620      if ( Agrif_probdim .EQ. 3 ) 
621     &       cureff = (oldB%imax(1)-oldB%imin(1)+1)*
622     &                (oldB%imax(2)-oldB%imin(2)+1)*
623     &                (oldB%imax(3)-oldB%imin(3)+1)
624      Nullify(parcbox)
625C 
626      do iii = 1 , Agrif_Probdim
627          newB%imax(iii) = oldB%imax(iii)           
628          newB%imin(iii) = oldB%imin(iii)
629      enddo     
630C
631      ValMax = 0
632      do iii = 1 , Agrif_Probdim
633         ValMax = Max(ValMax,istr(iii))
634      enddo
635C
636      if (istr(1) .EQ. ValMax ) then
637          newB%imax(1) = islice(1)
638          Call Agrif_Add_Rectangle(newB,parcbox)                   
639          newB%imin(1) = islice(1)+1
640          newB%imax(1) = oldB%imax(1)
641          Call Agrif_Add_Rectangle(newB,parcbox)
642      elseif ( Agrif_probdim .GE. 2 ) then
643         if (istr(2) .EQ. ValMax ) then
644            newB%imax(2) = islice(2)
645            Call Agrif_Add_Rectangle(newB,parcbox)
646            newB%imin(2) = islice(2)+1
647            newB%imax(2) = oldB%imax(2)
648            Call Agrif_Add_Rectangle(newB,parcbox)
649         elseif ( Agrif_probdim .EQ. 3 ) then
650            newB%imax(3) = islice(3)
651            Call Agrif_Add_Rectangle(newB,parcbox)
652            newB%imin(3) = islice(3)+1
653            newB%imax(3) = oldB%imax(3)
654            Call Agrif_Add_Rectangle(newB,parcbox)
655         endif
656      endif
657C     
658      do While (associated(parcbox))
659        newB = parcbox%r           
660C
661        if ( Agrif_probdim .EQ. 1 ) nbpoints = 
662     &                                 SUM(flag%iarray1(
663     &                                 newB%imin(1):newB%imax(1)))
664        if ( Agrif_probdim .EQ. 2 ) nbpoints = 
665     &                                 SUM(flag%iarray2(
666     &                                 newB%imin(1):newB%imax(1),
667     &                                 newB%imin(2):newB%imax(2)))
668        if ( Agrif_probdim .EQ. 3 ) nbpoints = 
669     &                                 SUM(flag%iarray3(
670     &                                 newB%imin(1):newB%imax(1),
671     &                                 newB%imin(2):newB%imax(2),
672     &                                 newB%imin(3):newB%imax(3)))
673C     
674       if ( Agrif_probdim .EQ. 1 ) 
675     &                 TailleTab = newB%imax(1)-newB%imin(1)+1
676       if ( Agrif_probdim .EQ. 2 ) 
677     &                 TailleTab = (newB%imax(1)-newB%imin(1)+1)*
678     &                             (newB%imax(2)-newB%imin(2)+1)
679       if ( Agrif_probdim .EQ. 3 ) 
680     &                 TailleTab = (newB%imax(1)-newB%imin(1)+1)*
681     &                             (newB%imax(2)-newB%imin(2)+1)*
682     &                             (newB%imax(3)-newB%imin(3)+1)
683
684        neweff = REAL(nbpoints) / TailleTab
685C     
686        if (nbpoints .GT. 0) then
687C     
688            if ((neweff .GT .Agrif_efficiency)) then
689                Call Agrif_Add_Rectangle(newB,boxlib)
690            else
691                tempbox => boxlib
692                newB2 = newB
693                Call Agrif_Clusternd(flag,
694     &                      boxlib,newB)
695C
696C               Compute new efficiency
697C
698                cureff = neweff
699                parcbox2 => boxlib
700                nbpoints = 0
701                nbpointsflag = 0
702C
703                do While (associated(parcbox2))
704                  if (associated(parcbox2,tempbox)) Exit
705                  newB = parcbox2%r
706C
707                  if ( Agrif_probdim .EQ. 1 ) ValSum = 
708     &                                 SUM(flag%iarray1(
709     &                                 newB%imin(1):newB%imax(1)))
710                  if ( Agrif_probdim .EQ. 2 ) ValSum = 
711     &                                 SUM(flag%iarray2(
712     &                                 newB%imin(1):newB%imax(1),
713     &                                 newB%imin(2):newB%imax(2)))
714                  if ( Agrif_probdim .EQ. 3 ) ValSum = 
715     &                                 SUM(flag%iarray3(
716     &                                 newB%imin(1):newB%imax(1),
717     &                                 newB%imin(2):newB%imax(2),
718     &                                 newB%imin(3):newB%imax(3)))
719C
720                  nbpointsflag = nbpointsflag + ValSum
721C
722                    if ( Agrif_probdim .EQ. 1 ) 
723     &                 TailleTab = newB%imax(1)-newB%imin(1)+1
724                    if ( Agrif_probdim .EQ. 2 ) 
725     &                 TailleTab = (newB%imax(1)-newB%imin(1)+1)*
726     &                             (newB%imax(2)-newB%imin(2)+1)
727                    if ( Agrif_probdim .EQ. 3 ) 
728     &                 TailleTab = (newB%imax(1)-newB%imin(1)+1)*
729     &                             (newB%imax(2)-newB%imin(2)+1)*
730     &                             (newB%imax(3)-newB%imin(3)+1)
731
732                  nbpoints = nbpoints + TailleTab
733C             
734                  parcbox2 => parcbox2%next 
735                enddo   
736C           
737                if  (REAL(nbpointsflag)/REAL(nbpoints)
738     &               .LT.(1.15*cureff)) then
739                    parcbox2 => boxlib           
740                    do While (associated(parcbox2))
741                      if (associated(parcbox2,tempbox)) Exit
742                      deallocate(parcbox2%r)
743                      parcbox2 => parcbox2%next             
744                    enddo
745                    boxlib => tempbox
746                    Call Agrif_Add_Rectangle(newB2,boxlib)
747                endif
748            endif
749        endif
750        parcbox => parcbox%next
751      enddo
752C     
753C     
754      Return
755C     
756      End Subroutine Agrif_Clusternd 
757C
758C     **************************************************************************
759CCC   Subroutine Agrif_Clusterslice
760C     **************************************************************************
761C                           
762      Subroutine Agrif_Clusterslice(sig,slice,str) 
763C
764C
765CCC   Description:
766CCC   
767C
768CC    Method:
769CC           
770C
771C     Declarations:
772C
773C     Arguments 
774      INTEGER                      :: slice,str
775      INTEGER,DIMENSION(slice:str) :: sig 
776C
777C     Local variables     
778      INTEGER                      :: ideb,ifin
779      INTEGER                      :: i,t,a,di,ts 
780      INTEGER,DIMENSION(slice:str) :: lap 
781C
782C   
783      ideb = slice
784      ifin = str
785C   
786      if (SIZE(sig) <= 2*Agrif_Minwidth) then
787          str = -1 
788          slice = -1 
789          Return
790      endif
791C     
792      t = -1 
793      a = -1 
794C
795      do i = ideb+Agrif_Minwidth-1,ifin-Agrif_Minwidth
796          if (sig(i) .EQ. 0) then
797              if ((i-ideb) < (ifin-i)) then
798                  di = i - ideb
799                else
800                  di = ifin - i 
801              endif
802C
803              if (di > t) then
804                a = i 
805                t = di 
806              endif
807         endif
808      enddo
809C     
810      if (a .NE. (-1)) then
811          slice = a 
812          str = t 
813          Return
814      endif
815C     
816      t = -1 
817      a = -1 
818C     
819      do i = ideb+1,ifin-1 
820        lap(i) = sig(i+1) + sig(i-1) - 2*sig(i) 
821      enddo
822C     
823      do i = ideb + Agrif_Minwidth-1,ifin-Agrif_Minwidth
824        if ((lap(i+1)*lap(i)) .LE. 0) then
825            ts = ABS(lap(i+1) - lap(i)) 
826            if (ts > t) then
827                t = ts 
828                a = i
829            endif
830       endif
831      enddo
832C     
833      if (a .EQ. (ideb + Agrif_Minwidth - 1)) then
834          a = -1
835          t = -1
836      endif
837C     
838      slice = a 
839      str = t 
840C
841C     
842      End Subroutine Agrif_Clusterslice       
843C
844C
845C   
846C     **************************************************************************
847CCC   Subroutine Agrif_Clusterprune
848C     **************************************************************************
849C     
850      Subroutine Agrif_Clusterprune(sig,pl,pu) 
851C
852C
853CCC   Description:
854CCC   
855C
856CC    Method:
857CC           
858C
859C     Declarations:
860C
861C     Arguments
862      INTEGER                  :: pl,pu 
863      INTEGER,DIMENSION(pl:pu) :: sig
864C
865C     Local variables     
866      INTEGER :: ideb,ifin       
867      INTEGER :: diff,addl,addu,udist,ldist 
868C
869C     
870      ideb = pl
871      ifin = pu
872C     
873      if (SIZE(sig) <= Agrif_Minwidth) then
874          return
875      endif
876C       
877      do While ((sig(pl) .EQ. 0) .AND. (pl < ifin)) 
878        pl = pl + 1 
879      enddo 
880C       
881      do While ((sig(pu) .EQ. 0) .AND. (pu > ideb)) 
882        pu = pu - 1 
883      enddo 
884C       
885      if ((pu-pl) < Agrif_Minwidth) then
886          diff = Agrif_Minwidth - (pu - pl + 1) 
887          udist = ifin - pu 
888          ldist = pl - ideb
889          addl = diff / 2 
890          addu = diff - addl 
891          if (addu > udist) then
892              addu = udist 
893              addl = diff - addu 
894          endif
895C         
896          if (addl > ldist) then
897              addl = ldist 
898              addu = diff - addl
899          endif
900C         
901          pu = pu + addu 
902          pl = pl - addl         
903C     
904      endif
905C       
906C
907      End Subroutine Agrif_Clusterprune
908C
909C
910C             
911C     **************************************************************************
912CCC   Subroutine Agrif_Add_Rectangle 
913C     **************************************************************************
914C       
915      Subroutine Agrif_Add_Rectangle(R,LR)
916C
917CCC   Description:
918CCC   Subroutine to add the Agrif_Rectangle R in a list managed by LR.
919C
920C     Declarations:
921C
922C     Arguments               
923      TYPE(AGRIF_rectangle)           :: R 
924      TYPE(AGRIF_lrectangle), Pointer :: LR
925C
926C     Local variable       
927      TYPE(AGRIF_lrectangle), Pointer :: newrect 
928C
929      INTEGER                         :: iii 
930C
931C       
932      allocate(newrect)
933      allocate(newrect % r)
934C
935      newrect % r = R
936C     
937      do iii = 1 , Agrif_Probdim
938         newrect % r % spaceref(iii) = Agrif_Coeffref(iii)
939         newrect % r % timeref(iii) = Agrif_Coeffreft(iii)
940      enddo
941C             
942      newrect % r % number = -1           
943      Nullify(newrect % r % childgrids)
944      newrect % next => LR 
945      LR => newrect 
946C
947C     
948      End Subroutine Agrif_Add_Rectangle   
949C 
950C
951C 
952C     **************************************************************************
953CCC   Subroutine Agrif_Read_Fix_Grd 
954C     **************************************************************************
955C     
956      Recursive Subroutine Agrif_Read_Fix_Grd(coarsegrid,j,nunit)
957C
958CCC   Description:
959CCC   Subroutine to create the grid hierarchy from the reading of the 
960CCC   AGRIF_FixedGrids.in file.
961C
962CC    Method:
963CC    Recursive subroutine and creation of a first grid hierarchy from the
964CC    reading of the AGRIF_FixedGrids.in file.       
965C
966C     Declarations:
967C
968C     Pointer argument     
969      TYPE(AGRIF_rectangle), Pointer   :: coarsegrid ! Pointer on the first grid
970                                                     ! of the grid hierarchy
971C                                   
972C     Scalar arguments                                   
973      INTEGER                          :: j          ! Number of the new grid
974      INTEGER                          :: nunit      ! unit associated with file
975C     
976C     Local variables     
977      TYPE(AGRIF_rectangle)            :: newrect    ! Pointer on a new grid   
978      TYPE(AGRIF_lrectangle), Pointer  :: parcours   ! Pointer for the recursive
979                                                     !    procedure
980      TYPE(AGRIF_lrectangle), Pointer  :: newlrect
981      TYPE(AGRIF_lrectangle), Pointer  :: end_list       
982      INTEGER                          :: i          ! for each child grid
983      INTEGER                          :: nb_grids   ! Number of child grids
984      INTEGER                          :: iii
985C         
986C
987      Nullify(newrect%childgrids)
988C     
989C     Reading of the number of child grids       
990      read(nunit,*) nb_grids
991C     
992C     coarsegrid%nbgridchild = nb_grids
993C     
994      allocate(end_list)
995C
996      nullify(end_list % r)
997      nullify(end_list % next)
998C     
999      coarsegrid % childgrids => end_list
1000C
1001C     Reading of imin(1),imax(1),imin(2),imax(2),imin(3),imax(3), and space and
1002C        time refinement factors for each child grid.
1003C     Creation and addition of the new grid to the grid hierarchy. 
1004C
1005      do i = 1,nb_grids
1006        allocate(newlrect)     
1007        newrect % number = j   ! Number of the grid
1008C
1009        if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
1010           if (Agrif_Probdim == 3) then 
1011            read(nunit,*) newrect % imin(1), newrect % imax(1),
1012     &                    newrect % imin(2), newrect % imax(2),
1013     &                    newrect % imin(3), newrect % imax(3),
1014     &                    newrect % spaceref(1),newrect % spaceref(2),
1015     &                    newrect % spaceref(3),
1016     &                    newrect % timeref(1),newrect % timeref(2),
1017     &                    newrect % timeref(3)
1018           elseif (Agrif_Probdim == 2) then           
1019            read(nunit,*) newrect % imin(1),newrect % imax(1),
1020     &                  newrect % imin(2),newrect % imax(2),
1021     &                    newrect % spaceref(1),newrect % spaceref(2),
1022     &                    newrect % timeref(1),newrect % timeref(2)
1023           elseif (Agrif_Probdim == 1) then
1024            read(nunit,*) newrect % imin(1), newrect % imax(1),
1025     &                    newrect % spaceref(1),
1026     &                    newrect % timeref(1)
1027           endif
1028        else
1029           if (Agrif_Probdim == 3) then 
1030            read(nunit,*) newrect % imin(1), newrect % imax(1),
1031     &                    newrect % imin(2), newrect % imax(2),
1032     &                    newrect % imin(3), newrect % imax(3),
1033     &                    newrect % spaceref(1),newrect % spaceref(2),
1034     &                    newrect % spaceref(3),
1035     &                    newrect % timeref(1)
1036           elseif (Agrif_Probdim == 2) then           
1037            read(nunit,*) newrect % imin(1),newrect % imax(1),
1038     &                  newrect % imin(2),newrect % imax(2),
1039     &                    newrect % spaceref(1),newrect % spaceref(2),
1040     &                    newrect % timeref(1)
1041           elseif (Agrif_Probdim == 1) then
1042            read(nunit,*) newrect % imin(1), newrect % imax(1),
1043     &                    newrect % spaceref(1),
1044     &                    newrect % timeref(1)
1045           endif
1046C
1047           if ( Agrif_probdim .GE. 2 ) then
1048              do iii = 2 , Agrif_probdim
1049                 newrect % timeref(iii) = newrect % timeref(1) 
1050              enddo
1051           endif
1052C
1053        endif
1054C
1055C       Addition to the grid hierarchy
1056C
1057        nullify(newrect % childgrids)
1058        j = j + 1
1059        Allocate(newlrect%r)
1060        newlrect % r = newrect 
1061        nullify(newlrect % next)
1062        end_list % next => newlrect
1063        end_list => end_list % next
1064      enddo
1065C     
1066      coarsegrid % childgrids => coarsegrid % childgrids % next
1067      parcours => coarsegrid % childgrids
1068C
1069C     Recursive operation to create the grid hierarchy branch by branch
1070C
1071      do while (associated(parcours))
1072        call Agrif_Read_Fix_Grd (parcours % r,j,nunit)
1073        parcours => parcours % next
1074      enddo
1075C     
1076C
1077      End Subroutine Agrif_Read_Fix_Grd       
1078C       
1079C 
1080C
1081C     **************************************************************************
1082CCC   Subroutine Agrif_Create_Grids 
1083C     **************************************************************************
1084C
1085      Recursive Subroutine Agrif_Create_Grids(g,coarsegrid)
1086C
1087CCC   Description:
1088CCC   Subroutine to create the grid hierarchy (g) from the one created with the
1089CCC   Agrif_Read_Fix_Grd or Agrif_Cluster_All procedures (coarsegrid).
1090C
1091CC    Method:
1092CC    Recursive subroutine.       
1093C
1094C     Declarations:
1095C
1096C     Pointer arguments       
1097      TYPE(AGRIF_grid)     , Pointer  :: g          ! Pointer on the root coarse
1098                                                    ! grid
1099      TYPE(AGRIF_rectangle), Pointer  :: coarsegrid ! Pointer on the root coarse
1100                                                    ! grid of the grid hierarchy
1101                                                    ! created with the
1102                                                    ! Agrif_Read_Fix_Grd
1103                                                    ! subroutine
1104C
1105C     Local pointers
1106      TYPE(Agrif_grid)      , Pointer :: newgrid    ! New grid
1107      TYPE(Agrif_pgrid)     , Pointer :: newpgrid
1108      TYPE(Agrif_pgrid)     , Pointer :: parcours2
1109      TYPE(Agrif_lrectangle), Pointer :: parcours
1110      TYPE(Agrif_pgrid)     , Pointer :: end_list
1111      TYPE(Agrif_pgrid)     , Pointer :: parcours3
1112C
1113C     Local scalars     
1114      LOGICAL                         :: nullliste
1115      INTEGER                         :: iii
1116      INTEGER                         :: moving_grid_id = 0     
1117
1118C
1119      parcours3 => g % child_grids
1120C     
1121      if (associated(parcours3)) then
1122          do While (associated(parcours3 % next))
1123            parcours3 => parcours3 % next
1124          enddo
1125          end_list => parcours3
1126          nullliste=.FALSE.
1127        else
1128          allocate(end_list)
1129          nullify(end_list % gr)
1130          nullify(end_list % next)     
1131          g % child_grids => end_list 
1132          parcours3 => end_list     
1133          nullliste=.TRUE.
1134      endif
1135C     
1136      parcours => coarsegrid % childgrids
1137C     
1138C     Creation of the grid hierarchy from the one created by using the 
1139C     Agrif_Read_Fix_Grd subroutine
1140C
1141      do while (associated(parcours))
1142        allocate(newgrid)       
1143        moving_grid_id=moving_grid_id+1
1144        newgrid % grid_id = moving_grid_id
1145        do iii = 1 , Agrif_Probdim
1146           newgrid % spaceref(iii) = parcours % r % spaceref(iii)
1147           newgrid % timeref(iii) = parcours % r % timeref(iii)
1148        enddo
1149C
1150        do iii = 1 , Agrif_Probdim
1151          newgrid % nb(iii) = (parcours % r % imax(iii) 
1152     &                       - parcours % r % imin(iii)) 
1153     &                       * parcours % r % spaceref(iii)
1154C     
1155          newgrid % ix(iii) =  parcours % r % imin(iii)
1156C
1157          newgrid % Agrif_d(iii) = g % Agrif_d(iii) 
1158     &                  / REAL(newgrid % spaceref(iii))
1159C
1160          newgrid % Agrif_x(iii) = g % Agrif_x(iii) +
1161     &      (parcours % r % imin(iii) - 1)* g % Agrif_d(iii)
1162C     
1163        enddo
1164C
1165C       Pointer on the parent grid                       
1166C
1167        newgrid % parent => g     
1168C     
1169C       Grid pointed by newgrid is a fixed grid     
1170C
1171        if (parcours % r % number .GT. 0) then     
1172            newgrid % fixed = .true. 
1173          else
1174            newgrid % fixed = .false.
1175        endif
1176C
1177C       Number of the grid pointed by newgrid
1178        newgrid % fixedrank = parcours % r % number
1179C           
1180C       No time calculation on this grid         
1181        newgrid % ngridstep = 0     
1182C
1183C       Test indicating if the current grid has a common border with the root 
1184C       coarse grid in the x direction
1185        do iii = 1 , Agrif_Probdim
1186           newgrid % NearRootBorder(iii) = .FALSE.
1187C       
1188           if ((newgrid % parent % NearRootBorder(iii)) .AND. 
1189     &         (newgrid % ix(iii) == 1)) then
1190               newgrid % NearRootBorder(iii) = .TRUE.
1191           endif
1192C
1193           newgrid % DistantRootBorder(iii) = .FALSE.
1194C 
1195           if ((newgrid % parent % DistantRootBorder(iii)) .AND. 
1196     &         (newgrid % ix(iii) + 
1197     &         (newgrid % nb(iii)/newgrid % spaceref(iii)) 
1198     &          - 1  == newgrid % parent % nb(iii))) then
1199               newgrid % DistantRootBorder(iii) = .TRUE.
1200           endif
1201        enddo
1202C
1203C       Writing in output files
1204C
1205        newgrid % oldgrid = .FALSE.     
1206C
1207C     
1208C       Definition of the CHARACTERistics of the variable of the grid pointed by
1209C       newgrid 
1210        Call Agrif_Create_Var (newgrid)
1211C     
1212C       Instanciation of the grid pointed by newgrid and its variables
1213        Call Agrif_Instance (newgrid)
1214C       
1215C       Nullify the variable of the grid pointed by newgrid
1216C
1217C
1218C       Addition of this grid to the grid hierarchy 
1219C     
1220        nullify(newgrid % child_grids)
1221        allocate(newpgrid) 
1222        newpgrid % gr => newgrid
1223        nullify(newpgrid % next)
1224        end_list % next => newpgrid
1225        end_list => end_list % next               
1226        parcours => parcours % next
1227C
1228C       Updating the total number of fixed grids
1229        if (newgrid % fixed) then
1230            AGRIF_nbfixedgrids = AGRIF_nbfixedgrids + 1
1231        endif
1232C                 
1233      enddo
1234C
1235C
1236      if (nullliste) then
1237          g % child_grids => g % child_grids % next
1238          parcours2 => g % child_grids
1239          deallocate(parcours3)
1240        else
1241          parcours2 => parcours3 % next
1242      endif
1243C     
1244      parcours => coarsegrid % childgrids
1245C
1246C     Recursive call to the subroutine Agrif_Create_Fixed_Grids to create the
1247C     grid hierarchy
1248C     
1249      do while (associated(parcours))
1250        Call Agrif_Create_Grids (parcours2 % gr,parcours % r)
1251        parcours => parcours % next
1252        parcours2 => parcours2 % next
1253      enddo 
1254C     
1255      Return     
1256C                 
1257      End Subroutine Agrif_Create_Grids
1258C
1259C     
1260C
1261C     **************************************************************************
1262CCC   Subroutine Agrif_Init_Hierarchy 
1263C     **************************************************************************
1264C
1265      Recursive Subroutine Agrif_Init_Hierarchy(g) 
1266C
1267CCC   Description:
1268CCC   Subroutine to initialize all the grids except the root coarse grid (this 
1269CCC   one, pointed by AGRIF_mygrid, is initialized by the subroutine
1270CCC   Agrif_Init_Grids defi ned in the module Agrif_Util and called in the main 
1271CCC   program ). 
1272C
1273CC    Method:
1274CC    Recursive subroutine.       
1275C
1276C     Declarations:
1277C
1278C     Pointer argument     
1279      TYPE(AGRIF_grid), Pointer  :: g         ! Pointer on the root coarse grid
1280C     
1281C     Local variables     
1282      TYPE(AGRIF_pgrid), Pointer :: parcours  ! Pointer for the recursive call
1283      LOGICAL                    :: Init_Hierarchy
1284C     
1285C
1286      parcours=>g%child_grids
1287C     
1288      do while (associated(parcours))
1289        Init_Hierarchy = .false.
1290        if ( AGRIF_USE_FIXED_GRIDS .EQ. 1 .OR. 
1291     &       AGRIF_USE_ONLY_FIXED_GRIDS .EQ. 1 ) then
1292           if ((parcours%gr%fixed) 
1293     &         .AND. (Agrif_mygrid%ngridstep == 0)) then
1294              Init_Hierarchy = .true.
1295           endif     
1296       endif
1297C
1298       if (.NOT. parcours%gr%fixed) Init_Hierarchy = .true.
1299       if (parcours % gr % oldgrid) Init_Hierarchy = .false.
1300C
1301       if (Init_Hierarchy) then
1302C
1303C           Instanciation of the grid pointed by parcours%gr and its variables 
1304            Call Agrif_Instance (parcours % gr)
1305C   
1306C           Allocation of the arrays containing values of the variables of the
1307C           grid pointed by parcours%gr     
1308C     
1309            Call Agrif_Allocation (parcours % gr)     
1310C       
1311            Call Agrif_Instance(parcours % gr)
1312C
1313            if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
1314              Call Agrif_Allocate_Restore (parcours % gr)
1315            endif
1316C
1317            if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
1318C              Initialization by copy of the grids created by clustering 
1319               Call AGRIF_CopyFromold_All (parcours%gr,
1320     &                                     Agrif_oldmygrid)
1321            endif
1322C
1323C           Initialization by interpolation 
1324C           (this routine is written by the user) 
1325            Call Agrif_InitValues()
1326C
1327            if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
1328               Call Agrif_Free_Restore (parcours % gr)
1329            endif
1330C
1331       endif                                 
1332       parcours => parcours % next 
1333C         
1334      enddo
1335C
1336      parcours => g % child_grids
1337C     
1338C     Recursive operation to initialize all the grids
1339      do while (associated(parcours))
1340        Call Agrif_Init_Hierarchy (parcours%gr)
1341        parcours => parcours%next
1342      enddo
1343C     
1344      End Subroutine Agrif_Init_Hierarchy 
1345C
1346C     **************************************************************************
1347CCC   Subroutine Agrif_Allocate_Restore 
1348C     **************************************************************************
1349C
1350      Subroutine Agrif_Allocate_Restore(Agrif_Gr)
1351C     
1352C     
1353C     Modules used:
1354C
1355      TYPE(AGRIF_grid), Pointer  :: Agrif_Gr   ! Pointer on the root coarse grid
1356C     
1357      INTEGER                    :: i
1358C
1359        do i = 1 , Agrif_NbVariables
1360            if ( Agrif_Mygrid%tabvars(i)%var % restaure ) then
1361            if ( Agrif_Gr%tabvars(i)%var % nbdim .EQ. 1 ) then   
1362            Allocate( Agrif_Gr%tabvars(i)%var% 
1363     &    Restore1D(lbound(Agrif_Gr%tabvars(i)%var%array1,1) 
1364     &    :ubound(Agrif_Gr%tabvars(i)%var%array1,1))) 
1365            Agrif_Gr%tabvars(i)%var%Restore1D = 0
1366C
1367            endif
1368            if ( Agrif_Gr%tabvars(i)%var % nbdim .EQ. 2 ) then
1369            Allocate( Agrif_Gr%tabvars(i)%var%Restore2D( 
1370     &      lbound(Agrif_Gr%tabvars(i)%var%array2,1):         
1371     &      ubound(Agrif_Gr%tabvars(i)%var%array2,1),         
1372     &      lbound(Agrif_Gr%tabvars(i)%var%array2,2)         
1373     &      :ubound(Agrif_Gr%tabvars(i)%var%array2,2)))         
1374            Agrif_Gr%tabvars(i)%var%Restore2D = 0
1375C
1376            endif
1377            if ( Agrif_Mygrid%tabvars(i)%var % nbdim .EQ. 3 ) then
1378C     
1379            Allocate( Agrif_Gr%tabvars(i)%var%Restore3D( 
1380     &      lbound(Agrif_Gr%tabvars(i)%var%array3,1):       
1381     &      ubound(Agrif_Gr%tabvars(i)%var%array3,1),       
1382     &      lbound(Agrif_Gr%tabvars(i)%var%array3,2):       
1383     &      ubound(Agrif_Gr%tabvars(i)%var%array3,2),       
1384     &      lbound(Agrif_Gr%tabvars(i)%var%array3,3):       
1385     &      ubound(Agrif_Gr%tabvars(i)%var%array3,3))) 
1386            Agrif_Gr%tabvars(i)%var%Restore3D = 0
1387            endif
1388C 
1389            endif
1390          enddo
1391C
1392      Return
1393C
1394C     
1395      End Subroutine Agrif_Allocate_Restore     
1396C
1397C
1398C
1399C
1400C     **************************************************************************
1401CCC   Subroutine Agrif_Free_Restore 
1402C     **************************************************************************
1403C
1404      Subroutine Agrif_Free_Restore(Agrif_Gr)
1405C
1406C     
1407C     Pointer argument     
1408      TYPE(AGRIF_grid), Pointer  :: Agrif_Gr   ! Pointer on the root coarse grid
1409      INTEGER :: i     
1410C
1411      do i = 1 , Agrif_NbVariables
1412         if ( Agrif_Mygrid % tabvars(i) % var % restaure) then
1413C 
1414            if (associated(Agrif_Gr%tabvars(i)%var%Restore1D)) then
1415               Deallocate(Agrif_Gr%tabvars(i)%var%Restore1D)
1416            endif
1417            if (associated(Agrif_Gr%tabvars(i)%var%Restore2D)) then
1418               Deallocate(Agrif_Gr%tabvars(i)%var%Restore2D)
1419            endif
1420            if (associated(Agrif_Gr%tabvars(i)%var%Restore3D)) then
1421               Deallocate(Agrif_Gr%tabvars(i)%var%Restore3D)
1422            endif
1423            if (associated(Agrif_Gr%tabvars(i)%var%Restore4D)) then
1424               Deallocate(Agrif_Gr%tabvars(i)%var%Restore4D)
1425            endif
1426            if (associated(Agrif_Gr%tabvars(i)%var%Restore5D)) then
1427               Deallocate(Agrif_Gr%tabvars(i)%var%Restore5D)
1428            endif
1429            if (associated(Agrif_Gr%tabvars(i)%var%Restore6D)) then
1430               Deallocate(Agrif_Gr%tabvars(i)%var%Restore6D)
1431            endif
1432C 
1433        endif
1434      enddo
1435C 
1436      Return
1437C
1438C     
1439      End Subroutine Agrif_Free_Restore
1440C
1441C
1442C
1443      End Module Agrif_Clustering
Note: See TracBrowser for help on using the repository browser.