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 branches/devmercator2010/AGRIF/AGRIF_FILES – NEMO

source: branches/devmercator2010/AGRIF/AGRIF_FILES/modsauv.F @ 2287

Last change on this file since 2287 was 1200, checked in by rblod, 16 years ago

Adapt Agrif to the new SBC and correct several bugs for agrif (restart writing and reading), see ticket #133
Note : this fix does not work yet on NEC computerq (sxf90/360)
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 26.9 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_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.