New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
modsauv.F in vendors/AGRIF/current/AGRIF_FILES – NEMO

source: vendors/AGRIF/current/AGRIF_FILES/modsauv.F @ 1901

Last change on this file since 1901 was 1901, checked in by flavoni, 14 years ago

importing AGRIF vendor
File size: 26.9 KB
Line 
1!
2! $Id: modsauv.F 1200 2008-09-24 13:05:20Z rblod $
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_Save 
26C
27      Module Agrif_Save 
28C
29CCC   Description:   
30CCC   Module for the initialization by copy of the grids created by clustering.
31C
32C     Modules used:
33C     
34      Use Agrif_Types
35      Use Agrif_Link
36      Use Agrif_Arrays
37C
38      IMPLICIT NONE
39C
40      Contains
41C     Definition of procedures contained in this module.
42C
43C
44C
45C     **************************************************************************
46CCC   Subroutine Agrif_Free_data_before
47C     **************************************************************************
48C
49      Subroutine Agrif_Free_data_before(Agrif_Gr)
50C
51CCC   Description:
52CCC   
53C
54CC    Method:
55CC           
56C
57C     Declarations:
58C
59     
60C     
61C     Pointer argument   
62      TYPE(Agrif_Grid),pointer   :: Agrif_Gr ! Pointer on the current grid
63      INTEGER i 
64C
65C   
66      do i = 1 , AGRIF_NbVariables
67         if ( .NOT. Agrif_Mygrid % tabvars(i) % var % restaure) then
68C 
69            if (associated(Agrif_Gr%tabvars(i)%var%array1)) then
70               Deallocate(Agrif_Gr%tabvars(i)%var%array1)
71            endif
72            if (associated(Agrif_Gr%tabvars(i)%var%array2)) then
73               Deallocate(Agrif_Gr%tabvars(i)%var%array2)
74            endif
75            if (associated(Agrif_Gr%tabvars(i)%var%array3)) then
76               Deallocate(Agrif_Gr%tabvars(i)%var%array3)
77            endif
78            if (associated(Agrif_Gr%tabvars(i)%var%array4)) then
79               Deallocate(Agrif_Gr%tabvars(i)%var%array4)
80            endif
81            if (associated(Agrif_Gr%tabvars(i)%var%array5)) then
82               Deallocate(Agrif_Gr%tabvars(i)%var%array5)
83            endif
84            if (associated(Agrif_Gr%tabvars(i)%var%array6)) then
85               Deallocate(Agrif_Gr%tabvars(i)%var%array6)
86            endif
87C
88            if (associated(Agrif_Gr%tabvars(i)%var%darray1)) then
89               Deallocate(Agrif_Gr%tabvars(i)%var%darray1)
90            endif
91            if (associated(Agrif_Gr%tabvars(i)%var%darray2)) then
92               Deallocate(Agrif_Gr%tabvars(i)%var%darray2)
93            endif
94            if (associated(Agrif_Gr%tabvars(i)%var%darray3)) then
95               Deallocate(Agrif_Gr%tabvars(i)%var%darray3)
96            endif
97            if (associated(Agrif_Gr%tabvars(i)%var%darray4)) then
98               Deallocate(Agrif_Gr%tabvars(i)%var%darray4)
99            endif
100            if (associated(Agrif_Gr%tabvars(i)%var%darray5)) then
101               Deallocate(Agrif_Gr%tabvars(i)%var%darray5)
102            endif
103            if (associated(Agrif_Gr%tabvars(i)%var%darray6)) then
104               Deallocate(Agrif_Gr%tabvars(i)%var%darray6)
105            endif
106C
107            if (associated(Agrif_Gr%tabvars(i)%var%larray1)) then
108               Deallocate(Agrif_Gr%tabvars(i)%var%larray1)
109            endif
110            if (associated(Agrif_Gr%tabvars(i)%var%larray2)) then
111               Deallocate(Agrif_Gr%tabvars(i)%var%larray2)
112            endif
113            if (associated(Agrif_Gr%tabvars(i)%var%larray3)) then
114               Deallocate(Agrif_Gr%tabvars(i)%var%larray3)
115            endif
116            if (associated(Agrif_Gr%tabvars(i)%var%larray4)) then
117               Deallocate(Agrif_Gr%tabvars(i)%var%larray4)
118            endif
119            if (associated(Agrif_Gr%tabvars(i)%var%larray5)) then
120               Deallocate(Agrif_Gr%tabvars(i)%var%larray5)
121            endif
122            if (associated(Agrif_Gr%tabvars(i)%var%larray6)) then
123               Deallocate(Agrif_Gr%tabvars(i)%var%larray6)
124            endif
125C
126            if (associated(Agrif_Gr%tabvars(i)%var%iarray1)) then
127               Deallocate(Agrif_Gr%tabvars(i)%var%iarray1)
128            endif
129            if (associated(Agrif_Gr%tabvars(i)%var%iarray2)) then
130               Deallocate(Agrif_Gr%tabvars(i)%var%iarray2)
131            endif
132            if (associated(Agrif_Gr%tabvars(i)%var%iarray3)) then
133               Deallocate(Agrif_Gr%tabvars(i)%var%iarray3)
134            endif
135            if (associated(Agrif_Gr%tabvars(i)%var%iarray4)) then
136               Deallocate(Agrif_Gr%tabvars(i)%var%iarray4)
137            endif
138            if (associated(Agrif_Gr%tabvars(i)%var%iarray5)) then
139               Deallocate(Agrif_Gr%tabvars(i)%var%iarray5)
140            endif
141            if (associated(Agrif_Gr%tabvars(i)%var%iarray6)) then
142               Deallocate(Agrif_Gr%tabvars(i)%var%iarray6)
143            endif
144C
145            if (associated(Agrif_Gr%tabvars(i)%var%carray1)) then
146               Deallocate(Agrif_Gr%tabvars(i)%var%carray1)
147            endif
148            if (associated(Agrif_Gr%tabvars(i)%var%carray2)) then
149               Deallocate(Agrif_Gr%tabvars(i)%var%carray2)
150            endif
151C
152            if (associated(Agrif_Gr%tabvars(i)%var%oldvalues2D)) then
153               Deallocate(Agrif_Gr%tabvars(i)%var%oldvalues2D)
154            endif
155            if (associated(Agrif_Gr%tabvars(i)%var%interpIndex)) then
156               Deallocate(Agrif_Gr%tabvars(i)%var%interpIndex)
157            endif
158           
159            if (associated(Agrif_Gr%tabvars(i)%var%posvar)) then
160               Deallocate(Agrif_Gr%tabvars(i)%var%posvar)
161            endif     
162           
163            if (associated(Agrif_Gr%tabvars(i)%var%interptab)) then
164               Deallocate(Agrif_Gr%tabvars(i)%var%interptab)
165            endif 
166           
167       endif
168           
169C
170       if (associated(Agrif_Gr%tabvars(i)%var%list_interp)) then
171         Call Agrif_Free_list_interp
172     &                          (Agrif_Gr%tabvars(i)%var%list_interp)
173       endif                             
174C
175       if ( .NOT. Agrif_Mygrid % tabvars(i) % var % restaure) then
176            Deallocate(Agrif_Gr%tabvars(i)%var)
177C 
178        endif
179      enddo
180C
181C 
182C
183      if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
184         if ( Agrif_Probdim .EQ. 1 ) Deallocate(Agrif_Gr%tabpoint1D)
185         if ( Agrif_Probdim .EQ. 2 ) Deallocate(Agrif_Gr%tabpoint2D)
186         if ( Agrif_Probdim .EQ. 3 ) Deallocate(Agrif_Gr%tabpoint3D)
187      endif
188C         
189      Return
190C
191C
192      End Subroutine Agrif_Free_data_before
193C
194C
195      Recursive Subroutine Agrif_Free_list_interp(list_interp)
196      TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp
197     
198      if (associated(list_interp%suiv))
199     &      Call Agrif_Free_list_interp(list_interp%suiv)
200     
201#ifdef AGRIF_MPI
202       Deallocate(list_interp%interp_loc%tab4t)
203       Deallocate(list_interp%interp_loc%memberinall)
204       Deallocate(list_interp%interp_loc%sendtoproc1)
205       Deallocate(list_interp%interp_loc%recvfromproc1)
206#endif
207       Deallocate(list_interp%interp_loc)
208       Deallocate(list_interp)
209       Nullify(list_interp)
210
211      End Subroutine Agrif_Free_list_interp     
212C
213C     **************************************************************************
214CCC   Subroutine Agrif_Free_data_after
215C     **************************************************************************
216C     
217      Subroutine Agrif_Free_data_after(Agrif_Gr)
218C
219CCC   Description:
220CCC   
221C
222CC    Method:
223CC           
224C
225C     Declarations:
226C
227C
228     
229C
230C     Pointer argument   
231      TYPE(Agrif_Grid),pointer   :: Agrif_Gr  ! Pointer on the current grid
232      INTEGER i
233C
234C     
235      do i = 1 , AGRIF_NbVariables
236         if ( Agrif_Mygrid % tabvars(i) % var % restaure) then
237C 
238            if (associated(Agrif_Gr%tabvars(i)%var%array1)) then
239               Deallocate(Agrif_Gr%tabvars(i)%var%array1)
240            endif
241            if (associated(Agrif_Gr%tabvars(i)%var%array2)) then
242               Deallocate(Agrif_Gr%tabvars(i)%var%array2)
243            endif
244            if (associated(Agrif_Gr%tabvars(i)%var%array3)) then
245               Deallocate(Agrif_Gr%tabvars(i)%var%array3)
246            endif
247            if (associated(Agrif_Gr%tabvars(i)%var%array4)) then
248               Deallocate(Agrif_Gr%tabvars(i)%var%array4)
249            endif
250            if (associated(Agrif_Gr%tabvars(i)%var%array5)) then
251               Deallocate(Agrif_Gr%tabvars(i)%var%array5)
252            endif
253            if (associated(Agrif_Gr%tabvars(i)%var%array6)) then
254               Deallocate(Agrif_Gr%tabvars(i)%var%array6)
255            endif
256!
257            if (associated(Agrif_Gr%tabvars(i)%var%darray1)) then
258               Deallocate(Agrif_Gr%tabvars(i)%var%darray1)
259            endif
260            if (associated(Agrif_Gr%tabvars(i)%var%darray2)) then
261               Deallocate(Agrif_Gr%tabvars(i)%var%darray2)
262            endif
263            if (associated(Agrif_Gr%tabvars(i)%var%darray3)) then
264               Deallocate(Agrif_Gr%tabvars(i)%var%darray3)
265            endif
266            if (associated(Agrif_Gr%tabvars(i)%var%darray4)) then
267               Deallocate(Agrif_Gr%tabvars(i)%var%darray4)
268            endif
269            if (associated(Agrif_Gr%tabvars(i)%var%darray5)) then
270               Deallocate(Agrif_Gr%tabvars(i)%var%darray5)
271            endif
272            if (associated(Agrif_Gr%tabvars(i)%var%darray6)) then
273               Deallocate(Agrif_Gr%tabvars(i)%var%darray6)
274            endif
275!
276            if (associated(Agrif_Gr%tabvars(i)%var%larray1)) then
277               Deallocate(Agrif_Gr%tabvars(i)%var%larray1)
278            endif
279            if (associated(Agrif_Gr%tabvars(i)%var%larray2)) then
280               Deallocate(Agrif_Gr%tabvars(i)%var%larray2)
281            endif
282            if (associated(Agrif_Gr%tabvars(i)%var%larray3)) then
283               Deallocate(Agrif_Gr%tabvars(i)%var%larray3)
284            endif
285            if (associated(Agrif_Gr%tabvars(i)%var%larray4)) then
286               Deallocate(Agrif_Gr%tabvars(i)%var%larray4)
287            endif
288            if (associated(Agrif_Gr%tabvars(i)%var%larray5)) then
289               Deallocate(Agrif_Gr%tabvars(i)%var%larray5)
290            endif
291            if (associated(Agrif_Gr%tabvars(i)%var%larray6)) then
292               Deallocate(Agrif_Gr%tabvars(i)%var%larray6)
293            endif
294!
295            if (associated(Agrif_Gr%tabvars(i)%var%iarray1)) then
296               Deallocate(Agrif_Gr%tabvars(i)%var%iarray1)
297            endif
298            if (associated(Agrif_Gr%tabvars(i)%var%iarray2)) then
299               Deallocate(Agrif_Gr%tabvars(i)%var%iarray2)
300            endif
301            if (associated(Agrif_Gr%tabvars(i)%var%iarray3)) then
302               Deallocate(Agrif_Gr%tabvars(i)%var%iarray3)
303            endif
304            if (associated(Agrif_Gr%tabvars(i)%var%iarray4)) then
305               Deallocate(Agrif_Gr%tabvars(i)%var%iarray4)
306            endif
307            if (associated(Agrif_Gr%tabvars(i)%var%iarray5)) then
308               Deallocate(Agrif_Gr%tabvars(i)%var%iarray5)
309            endif
310            if (associated(Agrif_Gr%tabvars(i)%var%iarray6)) then
311               Deallocate(Agrif_Gr%tabvars(i)%var%iarray6)
312            endif
313!
314            if (associated(Agrif_Gr%tabvars(i)%var%carray1)) then
315               Deallocate(Agrif_Gr%tabvars(i)%var%carray1)
316            endif
317            if (associated(Agrif_Gr%tabvars(i)%var%carray2)) then
318               Deallocate(Agrif_Gr%tabvars(i)%var%carray2)
319            endif
320!
321            if (associated(Agrif_Gr%tabvars(i)%var%oldvalues2D)) then
322               Deallocate(Agrif_Gr%tabvars(i)%var%oldvalues2D)
323            endif
324            if (associated(Agrif_Gr%tabvars(i)%var%interpIndex)) then
325               Deallocate(Agrif_Gr%tabvars(i)%var%interpIndex)
326            endif
327           
328            if (associated(Agrif_Gr%tabvars(i)%var%posvar)) then
329               Deallocate(Agrif_Gr%tabvars(i)%var%posvar)
330            endif     
331           
332            if (associated(Agrif_Gr%tabvars(i)%var%interptab)) then
333               Deallocate(Agrif_Gr%tabvars(i)%var%interptab)
334            endif                 
335!
336            Deallocate(Agrif_Gr%tabvars(i)%var)
337!
338         endif
339      enddo
340C
341C     
342      Return
343C
344C
345      End Subroutine Agrif_Free_data_after     
346C
347C
348CC    **************************************************************************
349CCC   Subroutine AGRIF_CopyFromold_All
350C     **************************************************************************
351C
352      Recursive Subroutine AGRIF_CopyFromold_All(g,oldchildgrids)
353C
354CCC   Description:
355CCC   Routine called in the Agrif_Init_Hierarchy procedure 
356C       (Agrif_Clustering module). 
357C
358CC    Method:       
359C
360C     Declarations:
361C
362     
363C     
364C     Pointer argument   
365      TYPE(AGRIF_grid),pointer   :: g ! Pointer on the current grid
366      TYPE(AGRIF_pgrid),pointer   :: oldchildgrids
367C
368C     Local pointer
369      TYPE(AGRIF_pgrid),pointer  :: parcours ! Pointer for the recursive
370                                             ! procedure
371      REAL g_eps,eps,oldgrid_eps
372      INTEGER :: out
373      INTEGER :: iii
374C
375      out = 0
376C                                                                           
377      parcours => oldchildgrids 
378C
379      do while (associated(parcours))
380C 
381        if ((.NOT. g % fixed) .AND. (parcours % gr %oldgrid)) then
382C       
383            g_eps = huge(1.)
384            oldgrid_eps = huge(1.)
385            do iii = 1 , Agrif_Probdim
386               g_eps = min(g_eps,g % Agrif_d(iii))
387               oldgrid_eps = min(oldgrid_eps,
388     &                       parcours % gr % Agrif_d(iii))
389            enddo
390C
391            eps = min(g_eps,oldgrid_eps)/100.                 
392C
393            do iii = 1 , Agrif_Probdim
394
395               if (g % Agrif_d(iii) .LT. 
396     &             (parcours % gr % Agrif_d(iii) - eps)) then
397C           
398                   parcours => parcours % next
399C           
400                   out = 1
401C   
402                   Exit
403C             
404               endif
405C     
406            enddo
407        if ( out .EQ. 1 ) Cycle
408C
409            Call AGRIF_CopyFromOld(g,parcours%gr)
410C
411        endif
412C                     
413        Call Agrif_CopyFromold_All
414     &             (g, parcours % gr % child_grids)
415C       
416        parcours => parcours % next
417C       
418      enddo
419C
420C     
421      Return     
422C
423C
424      End Subroutine AGRIF_CopyFromold_All
425C
426C
427C     
428C     **************************************************************************
429CCC   Subroutine Agrif_CopyFromold
430C     **************************************************************************
431C     
432      Subroutine Agrif_CopyFromold(Agrif_New_Gr,Agrif_Old_Gr)
433C
434CCC   Description:
435CCC   Call to the Agrif_Copy procedure.
436C
437CC    Method:
438CC           
439C
440C     Declarations:
441C
442     
443C     
444C     Pointer argument   
445      TYPE(Agrif_Grid),Pointer   :: Agrif_New_Gr  ! Pointer on the current grid
446      TYPE(Agrif_Grid),Pointer :: Agrif_Old_Gr    ! Pointer on an old grid
447      INTEGER :: i
448C
449C     
450      do i = 1 , AGRIF_NbVariables
451         if ( Agrif_Mygrid % tabvars(i) % var % restaure ) then
452C
453            Call Agrif_Copy(Agrif_New_Gr,Agrif_Old_Gr,
454     &           Agrif_New_Gr % tabvars(i),
455     &           Agrif_Old_Gr % tabvars(i))
456C
457        endif
458      enddo
459
460C     
461C           
462      Return
463C
464C     
465      End Subroutine Agrif_CopyFromold
466C
467C
468CC
469C
470C
471C     **************************************************************************
472CCC   Subroutine Agrif_Copy
473C     **************************************************************************
474C     
475      Subroutine Agrif_Copy(Agrif_New_Gr,Agrif_Old_Gr,New_Var,Old_Var)
476C     
477CCC   Description:
478CCC   Sets arguments of the Agrif_UpdatenD procedures, n being the number of 
479CCC   DIMENSION of the grid variable.
480C
481CC    Method:
482CC           
483C
484C     Declarations:
485C
486     
487C
488C     Pointer argument   
489      TYPE(Agrif_Grid),Pointer   :: Agrif_New_Gr   ! Pointer on the current grid
490      TYPE(Agrif_Grid), Pointer :: Agrif_Old_Gr    ! Pointer on an old grid
491      TYPE(Agrif_Pvariable) :: New_Var, Old_Var
492      INTEGER :: nbdim                  ! Number of dimensions of the current
493                                        ! grid     
494      INTEGER,DIMENSION(6) :: pttabnew  ! Indexes of the first point in the
495                                        ! domain
496      INTEGER,DIMENSION(6) :: petabnew  ! Indexes of the first point in the
497                                        ! domain
498      INTEGER,DIMENSION(6) :: pttabold  ! Indexes of the first point in the
499                                        ! domain
500      INTEGER,DIMENSION(6) :: petabold  ! Indexes of the first point in the
501                                        ! domain
502      INTEGER,DIMENSION(6) :: nbtabold  ! Number of cells in each direction
503     
504      INTEGER,DIMENSION(6) :: nbtabnew  ! Number of cells in each direction   
505      TYPE(AGRIF_Variable), Pointer :: root ! Pointer on the variable of the
506                                            ! root grid
507      REAL, DIMENSION(6) :: snew,sold
508      REAL, DIMENSION(6) :: dsnew,dsold                             
509      REAL :: eps
510      INTEGER :: n
511C
512C 
513      root => New_Var % var % root_var 
514C     
515      nbdim = root % nbdim
516C         
517      do n=1,nbdim
518C 
519        select case(root % interptab(n))
520C       
521        case('x')               
522C
523          pttabnew(n) = root % point(1)
524C       
525          pttabold(n) = root % point(1)
526C       
527          snew(n) = Agrif_New_Gr % Agrif_x(1)
528C
529          sold(n) = Agrif_Old_Gr % Agrif_x(1) 
530C       
531          dsnew(n) = Agrif_New_Gr % Agrif_d(1)
532C
533          dsold(n) = Agrif_Old_Gr % Agrif_d(1)
534C                     
535          if (root % posvar(n) .EQ. 1) then
536C         
537              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(1)
538C         
539              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(1)         
540C       
541            else
542C         
543              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(1) - 1
544C         
545              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(1) - 1
546C
547              snew(n) = snew(n) + dsnew(n)/2.
548C
549              sold(n) = sold(n) + dsold(n)/2.
550C       
551          endif           
552C       
553        case('y')
554C       
555          pttabnew(n) = root % point(2)
556C       
557          pttabold(n) = root % point(2)
558C       
559          snew(n) = Agrif_New_Gr % Agrif_x(2)
560C       
561          sold(n) = Agrif_Old_Gr % Agrif_x(2)
562C       
563          dsnew(n) = Agrif_New_Gr % Agrif_d(2)
564C       
565          dsold(n) = Agrif_Old_Gr % Agrif_d(2)
566C               
567          if (root % posvar(n) .EQ. 1) then
568C       
569              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(2)
570C         
571              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(2)         
572C       
573            else
574C         
575              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(2) - 1
576C         
577              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(2) - 1
578C
579              snew(n) = snew(n) + dsnew(n)/2.
580C
581              sold(n) = sold(n) + dsold(n)/2.                   
582C       
583          endif
584C       
585        case('z')
586C       
587          pttabnew(n) = root % point(3)
588C       
589          pttabold(n) = root % point(3)
590C       
591          snew(n) = Agrif_New_Gr % Agrif_x(3)
592C       
593          sold(n) = Agrif_Old_Gr % Agrif_x(3)
594C       
595          dsnew(n) = Agrif_New_Gr % Agrif_d(3)
596C       
597          dsold(n) = Agrif_Old_Gr % Agrif_d(3)
598C               
599          if (root % posvar(n) .EQ. 1) then
600C       
601              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(3)
602C         
603              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(3)         
604C       
605            else
606C         
607             petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(3) - 1
608C         
609             petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(3) - 1
610C
611             snew(n) = snew(n) + dsnew(n)/2.
612C
613             sold(n) = sold(n) + dsold(n)/2.                   
614C       
615          endif
616C         
617        case('N')
618C       
619          Call Agrif_nbdim_Get_bound(New_Var%var,
620     &                           pttabnew(n),petabnew(n),
621     &                           n,nbdim)
622C       
623          pttabold(n) = pttabnew(n)
624C     
625          petabold(n) = petabnew(n)
626C             
627          snew(n) = 0.
628C     
629          sold(n) = 0. 
630C     
631          dsnew(n) = 1.
632C     
633          dsold(n) = 1.
634C       
635        end select
636C     
637      enddo
638C     
639      do n = 1,nbdim
640C     
641        nbtabnew(n) = petabnew(n) - pttabnew(n)
642C     
643        nbtabold(n) = petabold(n) - pttabold(n)     
644C 
645      enddo     
646C
647      eps = min(minval(dsnew(1:nbdim)),minval(dsold(1:nbdim)))
648C     
649      eps = eps/100.     
650C     
651      do n = 1,nbdim
652C     
653        if (snew(n) .GT. (sold(n)+dsold(n)*nbtabold(n)+eps)) Return
654C     
655        if ((snew(n)+dsnew(n)*nbtabnew(n)-eps) .LT. sold(n)) Return
656C     
657      enddo
658C           
659C
660      Call AGRIF_CopynD
661     &        (New_Var,Old_Var,pttabold,petabold,pttabnew,petabnew,
662     &         sold,snew,dsold,dsnew,nbdim) 
663C     
664C 
665      Return
666C     
667C
668      End Subroutine Agrif_Copy
669C
670C
671C
672C     **************************************************************************
673CCC   Subroutine Agrif_CopynD
674C     **************************************************************************
675C     
676      Subroutine Agrif_CopynD(New_Var,Old_Var,pttabold,petabold,
677     &                        pttabnew,petabnew,sold,snew,dsold,
678     &                        dsnew,nbdim)
679C     
680CCC   Description:
681CCC   Copy of the nD New_Var variable from the nD Old_Var variable.
682C
683CC    Method:
684CC           
685C
686C     Declarations:
687C
688     
689C
690      INTEGER :: nbdim
691      TYPE(Agrif_Pvariable) :: New_Var, Old_Var     
692      INTEGER,DIMENSION(nbdim) :: pttabnew 
693      INTEGER,DIMENSION(nbdim) :: petabnew
694      INTEGER,DIMENSION(nbdim) :: pttabold
695      INTEGER,DIMENSION(nbdim) :: petabold     
696      REAL, DIMENSION(nbdim) :: snew,sold
697      REAL, DIMENSION(nbdim) :: dsnew,dsold 
698C
699      INTEGER :: i,j,k,l,m,n,i0,j0,k0,l0,m0,n0
700C
701      REAL, DIMENSION(nbdim) :: dim_gmin,dim_gmax
702      REAL, DIMENSION(nbdim) :: dim_newmin,dim_newmax
703      REAL, DIMENSION(nbdim) :: dim_min
704      INTEGER, DIMENSION(nbdim) :: ind_gmin,ind_newmin
705      INTEGER, DIMENSION(nbdim) ::  ind_newmax
706C               
707C
708      do i = 1,nbdim
709C     
710        dim_gmin(i) = sold(i)
711        dim_gmax(i) = sold(i) + (petabold(i)-pttabold(i)) * dsold(i)
712C 
713        dim_newmin(i) = snew(i)
714        dim_newmax(i) = snew(i) + (petabnew(i)-pttabnew(i)) * dsnew(i)
715C
716      enddo         
717C
718      do i = 1,nbdim
719C 
720        if (dim_gmax(i) .LT. dim_newmin(i)) Return
721C     
722        if (dim_gmin(i) .GT. dim_newmax(i)) Return
723C
724      enddo
725C
726C
727      do i = 1,nbdim
728C 
729        ind_newmin(i) = pttabnew(i) - floor(-(max(dim_gmin(i),
730     &                      dim_newmin(i))-dim_newmin(i))/dsnew(i)) 
731C     
732        dim_min(i) = snew(i) + (ind_newmin(i)-pttabnew(i))*dsnew(i)
733C     
734        ind_gmin(i) = pttabold(i) + nint((dim_min(i)-
735     &                dim_gmin(i))/dsold(i))     
736C
737        ind_newmax(i) = pttabnew(i) 
738     &                  + int((min(dim_gmax(i),dim_newmax(i))
739     &                         -dim_newmin(i))/dsnew(i))
740C
741      enddo 
742C
743C
744C
745      SELECT CASE (nbdim)
746      CASE (1)
747         i0 = ind_gmin(1)
748         do i = ind_newmin(1),ind_newmax(1)
749            New_Var % var % array1(i) =
750     &      Old_Var % var % array1(i0)
751            New_Var % var % restore1D(i) = 1   
752         i0 = i0 + int(dsnew(1)/dsold(1))
753         enddo
754      CASE (2)
755        i0 = ind_gmin(1)
756        do i = ind_newmin(1),ind_newmax(1)
757        j0 = ind_gmin(2)
758        do j = ind_newmin(2),ind_newmax(2)
759           New_Var % var % array2(i,j) =
760     &            Old_Var % var % array2(i0,j0)
761           New_Var % var % restore2D(i,j) = 1
762               j0 = j0 + int(dsnew(2)/dsold(2))
763        enddo
764        i0 = i0 + int(dsnew(1)/dsold(1))
765        enddo
766      CASE (3)
767        i0 = ind_gmin(1)
768        do i = ind_newmin(1),ind_newmax(1)
769        j0 = ind_gmin(2)
770        do j = ind_newmin(2),ind_newmax(2)
771        k0 = ind_gmin(3)
772        do k = ind_newmin(3),ind_newmax(3)
773           New_Var % var % array3(i,j,k) =
774     &                  Old_Var % var % array3(i0,j0,k0)
775           New_Var % var % restore3D(i,j,k) = 1   
776                     k0 = k0 + int(dsnew(3)/dsold(3))
777        enddo
778        j0 = j0 + int(dsnew(2)/dsold(2))
779        enddo
780        i0 = i0 + int(dsnew(1)/dsold(1))
781        enddo
782      CASE (4)
783        i0 = ind_gmin(1)
784        do i = ind_newmin(1),ind_newmax(1)
785        j0 = ind_gmin(2)
786        do j = ind_newmin(2),ind_newmax(2)
787        k0 = ind_gmin(3)
788        do k = ind_newmin(3),ind_newmax(3)
789        l0 = ind_gmin(4)
790        do l = ind_newmin(4),ind_newmax(4) 
791           New_Var % var % array4(i,j,k,l) =
792     &                        Old_Var % var % array4(i0,j0,k0,l0)
793           New_Var % var % restore4D(i,j,k,l) = 1   
794        l0 = l0 + int(dsnew(4)/dsold(4))
795        enddo
796        k0 = k0 + int(dsnew(3)/dsold(3))
797        enddo
798        j0 = j0 + int(dsnew(2)/dsold(2))
799        enddo
800        i0 = i0 + int(dsnew(1)/dsold(1))
801        enddo
802      CASE (5)
803        i0 = ind_gmin(1)
804        do i = ind_newmin(1),ind_newmax(1)
805        j0 = ind_gmin(2)
806        do j = ind_newmin(2),ind_newmax(2)
807        k0 = ind_gmin(3)
808        do k = ind_newmin(3),ind_newmax(3)
809        l0 = ind_gmin(4)
810        do l = ind_newmin(4),ind_newmax(4) 
811        m0 = ind_gmin(5)
812        do m = ind_newmin(5),ind_newmax(5)
813           New_Var % var % array5(i,j,k,l,m) =
814     &                        Old_Var % var % array5(i0,j0,k0,l0,m0)
815           New_Var % var % restore5D(i,j,k,l,m) = 1
816        m0 = m0 + int(dsnew(5)/dsold(5)) 
817        enddo
818        l0 = l0 + int(dsnew(4)/dsold(4))
819        enddo
820        k0 = k0 + int(dsnew(3)/dsold(3))
821        enddo
822        j0 = j0 + int(dsnew(2)/dsold(2))
823        enddo
824        i0 = i0 + int(dsnew(1)/dsold(1))
825        enddo
826      CASE (6)
827        i0 = ind_gmin(1)
828        do i = ind_newmin(1),ind_newmax(1)
829        j0 = ind_gmin(2)
830        do j = ind_newmin(2),ind_newmax(2)
831        k0 = ind_gmin(3)
832        do k = ind_newmin(3),ind_newmax(3)
833        l0 = ind_gmin(4)
834        do l = ind_newmin(4),ind_newmax(4) 
835        m0 = ind_gmin(5)
836        do m = ind_newmin(5),ind_newmax(5)
837        n0 = ind_gmin(6)
838        do n = ind_newmin(6),ind_newmax(6)
839           New_Var % var % array6(i,j,k,l,m,n) =
840     &                        Old_Var % var % array6(i0,j0,k0,l0,m0,n0)
841           New_Var % var % restore6D(i,j,k,l,m,n) = 1
842        n0 = n0 + int(dsnew(6)/dsold(6)) 
843        enddo
844        m0 = m0 + int(dsnew(5)/dsold(5)) 
845        enddo
846        l0 = l0 + int(dsnew(4)/dsold(4))
847        enddo
848        k0 = k0 + int(dsnew(3)/dsold(3))
849        enddo
850        j0 = j0 + int(dsnew(2)/dsold(2))
851        enddo
852        i0 = i0 + int(dsnew(1)/dsold(1))
853        enddo
854      END SELECT
855C           
856      Return
857C
858C
859      End Subroutine Agrif_CopynD                   
860C
861C
862C
863      End module Agrif_Save
Note: See TracBrowser for help on using the repository browser.