source: trunk/AGRIF/AGRIF_FILES/modsauv.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: 25.3 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
158C
159            Deallocate(Agrif_Gr%tabvars(i)%var)
160C 
161        endif
162      enddo
163C
164C 
165C
166      if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
167         if ( Agrif_Probdim .EQ. 1 ) Deallocate(Agrif_Gr%tabpoint1D)
168         if ( Agrif_Probdim .EQ. 2 ) Deallocate(Agrif_Gr%tabpoint2D)
169         if ( Agrif_Probdim .EQ. 3 ) Deallocate(Agrif_Gr%tabpoint3D)
170      endif
171C         
172      Return
173C
174C
175      End Subroutine Agrif_Free_data_before
176C
177C
178C
179C     **************************************************************************
180CCC   Subroutine Agrif_Free_data_after
181C     **************************************************************************
182C     
183      Subroutine Agrif_Free_data_after(Agrif_Gr)
184C
185CCC   Description:
186CCC   
187C
188CC    Method:
189CC           
190C
191C     Declarations:
192C
193C
194     
195C
196C     Pointer argument   
197      TYPE(Agrif_Grid),pointer   :: Agrif_Gr  ! Pointer on the current grid
198      INTEGER i
199C
200C     
201      do i = 1 , AGRIF_NbVariables
202         if ( Agrif_Mygrid % tabvars(i) % var % restaure) then
203C 
204            if (associated(Agrif_Gr%tabvars(i)%var%array1)) then
205               Deallocate(Agrif_Gr%tabvars(i)%var%array1)
206            endif
207            if (associated(Agrif_Gr%tabvars(i)%var%array2)) then
208               Deallocate(Agrif_Gr%tabvars(i)%var%array2)
209            endif
210            if (associated(Agrif_Gr%tabvars(i)%var%array3)) then
211               Deallocate(Agrif_Gr%tabvars(i)%var%array3)
212            endif
213            if (associated(Agrif_Gr%tabvars(i)%var%array4)) then
214               Deallocate(Agrif_Gr%tabvars(i)%var%array4)
215            endif
216            if (associated(Agrif_Gr%tabvars(i)%var%array5)) then
217               Deallocate(Agrif_Gr%tabvars(i)%var%array5)
218            endif
219            if (associated(Agrif_Gr%tabvars(i)%var%array6)) then
220               Deallocate(Agrif_Gr%tabvars(i)%var%array6)
221            endif
222!
223            if (associated(Agrif_Gr%tabvars(i)%var%darray1)) then
224               Deallocate(Agrif_Gr%tabvars(i)%var%darray1)
225            endif
226            if (associated(Agrif_Gr%tabvars(i)%var%darray2)) then
227               Deallocate(Agrif_Gr%tabvars(i)%var%darray2)
228            endif
229            if (associated(Agrif_Gr%tabvars(i)%var%darray3)) then
230               Deallocate(Agrif_Gr%tabvars(i)%var%darray3)
231            endif
232            if (associated(Agrif_Gr%tabvars(i)%var%darray4)) then
233               Deallocate(Agrif_Gr%tabvars(i)%var%darray4)
234            endif
235            if (associated(Agrif_Gr%tabvars(i)%var%darray5)) then
236               Deallocate(Agrif_Gr%tabvars(i)%var%darray5)
237            endif
238            if (associated(Agrif_Gr%tabvars(i)%var%darray6)) then
239               Deallocate(Agrif_Gr%tabvars(i)%var%darray6)
240            endif
241!
242            if (associated(Agrif_Gr%tabvars(i)%var%larray1)) then
243               Deallocate(Agrif_Gr%tabvars(i)%var%larray1)
244            endif
245            if (associated(Agrif_Gr%tabvars(i)%var%larray2)) then
246               Deallocate(Agrif_Gr%tabvars(i)%var%larray2)
247            endif
248            if (associated(Agrif_Gr%tabvars(i)%var%larray3)) then
249               Deallocate(Agrif_Gr%tabvars(i)%var%larray3)
250            endif
251            if (associated(Agrif_Gr%tabvars(i)%var%larray4)) then
252               Deallocate(Agrif_Gr%tabvars(i)%var%larray4)
253            endif
254            if (associated(Agrif_Gr%tabvars(i)%var%larray5)) then
255               Deallocate(Agrif_Gr%tabvars(i)%var%larray5)
256            endif
257            if (associated(Agrif_Gr%tabvars(i)%var%larray6)) then
258               Deallocate(Agrif_Gr%tabvars(i)%var%larray6)
259            endif
260!
261            if (associated(Agrif_Gr%tabvars(i)%var%iarray1)) then
262               Deallocate(Agrif_Gr%tabvars(i)%var%iarray1)
263            endif
264            if (associated(Agrif_Gr%tabvars(i)%var%iarray2)) then
265               Deallocate(Agrif_Gr%tabvars(i)%var%iarray2)
266            endif
267            if (associated(Agrif_Gr%tabvars(i)%var%iarray3)) then
268               Deallocate(Agrif_Gr%tabvars(i)%var%iarray3)
269            endif
270            if (associated(Agrif_Gr%tabvars(i)%var%iarray4)) then
271               Deallocate(Agrif_Gr%tabvars(i)%var%iarray4)
272            endif
273            if (associated(Agrif_Gr%tabvars(i)%var%iarray5)) then
274               Deallocate(Agrif_Gr%tabvars(i)%var%iarray5)
275            endif
276            if (associated(Agrif_Gr%tabvars(i)%var%iarray6)) then
277               Deallocate(Agrif_Gr%tabvars(i)%var%iarray6)
278            endif
279!
280            if (associated(Agrif_Gr%tabvars(i)%var%carray1)) then
281               Deallocate(Agrif_Gr%tabvars(i)%var%carray1)
282            endif
283            if (associated(Agrif_Gr%tabvars(i)%var%carray2)) then
284               Deallocate(Agrif_Gr%tabvars(i)%var%carray2)
285            endif
286!
287            if (associated(Agrif_Gr%tabvars(i)%var%oldvalues2D)) then
288               Deallocate(Agrif_Gr%tabvars(i)%var%oldvalues2D)
289            endif
290            if (associated(Agrif_Gr%tabvars(i)%var%interpIndex)) then
291               Deallocate(Agrif_Gr%tabvars(i)%var%interpIndex)
292            endif
293!
294            Deallocate(Agrif_Gr%tabvars(i)%var)
295!
296         endif
297      enddo
298C
299C     
300      Return
301C
302C
303      End Subroutine Agrif_Free_data_after     
304C
305C
306CC    **************************************************************************
307CCC   Subroutine AGRIF_CopyFromold_All
308C     **************************************************************************
309C
310      Recursive Subroutine AGRIF_CopyFromold_All(g,oldchildgrids)
311C
312CCC   Description:
313CCC   Routine called in the Agrif_Init_Hierarchy procedure 
314C       (Agrif_Clustering module). 
315C
316CC    Method:       
317C
318C     Declarations:
319C
320     
321C     
322C     Pointer argument   
323      TYPE(AGRIF_grid),pointer   :: g ! Pointer on the current grid
324      TYPE(AGRIF_pgrid),pointer   :: oldchildgrids
325C
326C     Local pointer
327      TYPE(AGRIF_pgrid),pointer  :: parcours ! Pointer for the recursive
328                                             ! procedure
329      REAL g_eps,eps,oldgrid_eps
330      INTEGER :: out
331      INTEGER :: iii
332C
333      out = 0
334C                                                                           
335      parcours => oldchildgrids 
336C
337      do while (associated(parcours))
338C 
339        if ((.NOT. g % fixed) .AND. (parcours % gr %oldgrid)) then
340C       
341            g_eps = huge(1.)
342            oldgrid_eps = huge(1.)
343            do iii = 1 , Agrif_Probdim
344               g_eps = min(g_eps,g % Agrif_d(iii))
345               oldgrid_eps = min(oldgrid_eps,
346     &                       parcours % gr % Agrif_d(iii))
347            enddo
348C
349            eps = min(g_eps,oldgrid_eps)/100.                 
350C
351
352            do iii = 1 , Agrif_Probdim
353               if (g % Agrif_d(iii) .LT. 
354     &             (parcours % gr % Agrif_d(iii) - eps)) then
355C           
356                   parcours => parcours % next
357C           
358                   out = 1
359C   
360                   Cycle
361C             
362               endif
363C     
364            enddo
365        if ( out .EQ. 1 ) Cycle
366C
367            Call AGRIF_CopyFromOld(g,parcours%gr)
368C
369        endif
370C                     
371        Call Agrif_CopyFromold_All
372     &             (g, parcours % gr % child_grids)
373C       
374        parcours => parcours % next
375C       
376      enddo
377C
378C     
379      Return     
380C
381C
382      End Subroutine AGRIF_CopyFromold_All
383C
384C
385C     
386C     **************************************************************************
387CCC   Subroutine Agrif_CopyFromold
388C     **************************************************************************
389C     
390      Subroutine Agrif_CopyFromold(Agrif_New_Gr,Agrif_Old_Gr)
391C
392CCC   Description:
393CCC   Call to the Agrif_Copy procedure.
394C
395CC    Method:
396CC           
397C
398C     Declarations:
399C
400     
401C     
402C     Pointer argument   
403      TYPE(Agrif_Grid),Pointer   :: Agrif_New_Gr  ! Pointer on the current grid
404      TYPE(Agrif_Grid),Pointer :: Agrif_Old_Gr    ! Pointer on an old grid
405      INTEGER :: i
406C
407C     
408      do i = 1 , AGRIF_NbVariables
409         if ( Agrif_Mygrid % tabvars(i) % var % restaure ) then
410C
411            Call Agrif_Copy(Agrif_New_Gr,Agrif_Old_Gr,
412     &           Agrif_New_Gr % tabvars(i),
413     &           Agrif_Old_Gr % tabvars(i))
414C
415        endif
416      enddo
417
418C     
419C           
420      Return
421C
422C     
423      End Subroutine Agrif_CopyFromold
424C
425C
426CC
427C
428C
429C     **************************************************************************
430CCC   Subroutine Agrif_Copy
431C     **************************************************************************
432C     
433      Subroutine Agrif_Copy(Agrif_New_Gr,Agrif_Old_Gr,New_Var,Old_Var)
434C     
435CCC   Description:
436CCC   Sets arguments of the Agrif_UpdatenD procedures, n being the number of 
437CCC   DIMENSION of the grid variable.
438C
439CC    Method:
440CC           
441C
442C     Declarations:
443C
444     
445C
446C     Pointer argument   
447      TYPE(Agrif_Grid),Pointer   :: Agrif_New_Gr   ! Pointer on the current grid
448      TYPE(Agrif_Grid), Pointer :: Agrif_Old_Gr    ! Pointer on an old grid
449      TYPE(Agrif_Pvariable) :: New_Var, Old_Var
450      INTEGER :: nbdim                  ! Number of dimensions of the current
451                                        ! grid     
452      INTEGER,DIMENSION(6) :: pttabnew  ! Indexes of the first point in the
453                                        ! domain
454      INTEGER,DIMENSION(6) :: petabnew  ! Indexes of the first point in the
455                                        ! domain
456      INTEGER,DIMENSION(6) :: pttabold  ! Indexes of the first point in the
457                                        ! domain
458      INTEGER,DIMENSION(6) :: petabold  ! Indexes of the first point in the
459                                        ! domain
460      INTEGER,DIMENSION(6) :: nbtabold  ! Number of cells in each direction
461     
462      INTEGER,DIMENSION(6) :: nbtabnew  ! Number of cells in each direction   
463      TYPE(AGRIF_Variable), Pointer :: root ! Pointer on the variable of the
464                                            ! root grid
465      REAL, DIMENSION(6) :: snew,sold
466      REAL, DIMENSION(6) :: dsnew,dsold                             
467      REAL :: eps
468      INTEGER :: n
469C
470C 
471      root => New_Var % var % root_var 
472C     
473      nbdim = root % nbdim
474C         
475      do n=1,nbdim
476C 
477        select case(root % interptab(n))
478C       
479        case('x')               
480C
481          pttabnew(n) = root % point(1)
482C       
483          pttabold(n) = root % point(1)
484C       
485          snew(n) = Agrif_New_Gr % Agrif_x(1)
486C
487          sold(n) = Agrif_Old_Gr % Agrif_x(1) 
488C       
489          dsnew(n) = Agrif_New_Gr % Agrif_d(1)
490C
491          dsold(n) = Agrif_Old_Gr % Agrif_d(1)
492C                     
493          if (root % posvar(n) .EQ. 1) then
494C         
495              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(1)
496C         
497              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(1)         
498C       
499            else
500C         
501              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(1) - 1
502C         
503              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(1) - 1
504C
505              snew(n) = snew(n) + dsnew(n)/2.
506C
507              sold(n) = sold(n) + dsold(n)/2.
508C       
509          endif           
510C       
511        case('y')
512C       
513          pttabnew(n) = root % point(2)
514C       
515          pttabold(n) = root % point(2)
516C       
517          snew(n) = Agrif_New_Gr % Agrif_x(2)
518C       
519          sold(n) = Agrif_Old_Gr % Agrif_x(2)
520C       
521          dsnew(n) = Agrif_New_Gr % Agrif_d(2)
522C       
523          dsold(n) = Agrif_Old_Gr % Agrif_d(2)
524C               
525          if (root % posvar(n) .EQ. 1) then
526C       
527              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(2)
528C         
529              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(2)         
530C       
531            else
532C         
533              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(2) - 1
534C         
535              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(2) - 1
536C
537              snew(n) = snew(n) + dsnew(n)/2.
538C
539              sold(n) = sold(n) + dsold(n)/2.                   
540C       
541          endif
542C       
543        case('z')
544C       
545          pttabnew(n) = root % point(3)
546C       
547          pttabold(n) = root % point(3)
548C       
549          snew(n) = Agrif_New_Gr % Agrif_x(3)
550C       
551          sold(n) = Agrif_Old_Gr % Agrif_x(3)
552C       
553          dsnew(n) = Agrif_New_Gr % Agrif_d(3)
554C       
555          dsold(n) = Agrif_Old_Gr % Agrif_d(3)
556C               
557          if (root % posvar(n) .EQ. 1) then
558C       
559              petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(3)
560C         
561              petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(3)         
562C       
563            else
564C         
565             petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(3) - 1
566C         
567             petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(3) - 1
568C
569             snew(n) = snew(n) + dsnew(n)/2.
570C
571             sold(n) = sold(n) + dsold(n)/2.                   
572C       
573          endif
574C         
575        case('N')
576C       
577          Call Agrif_nbdim_Get_bound(New_Var%var,
578     &                           pttabnew(n),petabnew(n),
579     &                           n,nbdim)
580C       
581          pttabold(n) = pttabnew(n)
582C     
583          petabold(n) = petabnew(n)
584C             
585          snew(n) = 0.
586C     
587          sold(n) = 0. 
588C     
589          dsnew(n) = 1.
590C     
591          dsold(n) = 1.
592C       
593        end select
594C     
595      enddo
596C     
597      do n = 1,nbdim
598C     
599        nbtabnew(n) = petabnew(n) - pttabnew(n)
600C     
601        nbtabold(n) = petabold(n) - pttabold(n)     
602C 
603      enddo     
604C
605      eps = min(minval(dsnew(1:nbdim)),minval(dsold(1:nbdim)))
606C     
607      eps = eps/100.     
608C     
609      do n = 1,nbdim
610C     
611        if (snew(n) .GT. (sold(n)+dsold(n)*nbtabold(n)+eps)) Return
612C     
613        if ((snew(n)+dsnew(n)*nbtabnew(n)-eps) .LT. sold(n)) Return
614C     
615      enddo
616C           
617C
618      Call AGRIF_CopynD
619     &        (New_Var,Old_Var,pttabold,petabold,pttabnew,petabnew,
620     &         sold,snew,dsold,dsnew,nbdim) 
621C     
622C 
623      Return
624C     
625C
626      End Subroutine Agrif_Copy
627C
628C
629C
630C     **************************************************************************
631CCC   Subroutine Agrif_CopynD
632C     **************************************************************************
633C     
634      Subroutine Agrif_CopynD(New_Var,Old_Var,pttabold,petabold,
635     &                        pttabnew,petabnew,sold,snew,dsold,
636     &                        dsnew,nbdim)
637C     
638CCC   Description:
639CCC   Copy of the nD New_Var variable from the nD Old_Var variable.
640C
641CC    Method:
642CC           
643C
644C     Declarations:
645C
646     
647C
648      INTEGER :: nbdim
649      TYPE(Agrif_Pvariable) :: New_Var, Old_Var     
650      INTEGER,DIMENSION(nbdim) :: pttabnew 
651      INTEGER,DIMENSION(nbdim) :: petabnew
652      INTEGER,DIMENSION(nbdim) :: pttabold
653      INTEGER,DIMENSION(nbdim) :: petabold     
654      REAL, DIMENSION(nbdim) :: snew,sold
655      REAL, DIMENSION(nbdim) :: dsnew,dsold 
656C
657      INTEGER :: i,j,k,l,m,n,i0,j0,k0,l0,m0,n0
658C
659      REAL, DIMENSION(nbdim) :: dim_gmin,dim_gmax
660      REAL, DIMENSION(nbdim) :: dim_newmin,dim_newmax
661      REAL, DIMENSION(nbdim) :: dim_min
662      INTEGER, DIMENSION(nbdim) :: ind_gmin,ind_newmin
663      INTEGER, DIMENSION(nbdim) ::  ind_newmax
664C               
665C
666      do i = 1,nbdim
667C     
668        dim_gmin(i) = sold(i)
669        dim_gmax(i) = sold(i) + (petabold(i)-pttabold(i)) * dsold(i)
670C 
671        dim_newmin(i) = snew(i)
672        dim_newmax(i) = snew(i) + (petabnew(i)-pttabnew(i)) * dsnew(i)
673C
674      enddo         
675C
676      do i = 1,nbdim
677C 
678        if (dim_gmax(i) .LT. dim_newmin(i)) Return
679C     
680        if (dim_gmin(i) .GT. dim_newmax(i)) Return
681C
682      enddo
683C
684C
685      do i = 1,nbdim
686C 
687        ind_newmin(i) = pttabnew(i) - floor(-(max(dim_gmin(i),
688     &                      dim_newmin(i))-dim_newmin(i))/dsnew(i)) 
689C     
690        dim_min(i) = snew(i) + (ind_newmin(i)-pttabnew(i))*dsnew(i)
691C     
692        ind_gmin(i) = pttabold(i) + nint((dim_min(i)-
693     &                dim_gmin(i))/dsold(i))     
694C
695        ind_newmax(i) = pttabnew(i) 
696     &                  + int((min(dim_gmax(i),dim_newmax(i))
697     &                         -dim_newmin(i))/dsnew(i))
698C
699      enddo 
700C
701C
702C
703      SELECT CASE (nbdim)
704      CASE (1)
705         i0 = ind_gmin(1)
706         do i = ind_newmin(1),ind_newmax(1)
707            New_Var % var % array1(i) =
708     &      Old_Var % var % array1(i0)
709            New_Var % var % restore1D(i) = 1   
710         i0 = i0 + int(dsnew(1)/dsold(1))
711         enddo
712      CASE (2)
713        i0 = ind_gmin(1)
714        do i = ind_newmin(1),ind_newmax(1)
715        j0 = ind_gmin(2)
716        do j = ind_newmin(2),ind_newmax(2)
717           New_Var % var % array2(i,j) =
718     &            Old_Var % var % array2(i0,j0)
719           New_Var % var % restore2D(i,j) = 1
720               j0 = j0 + int(dsnew(2)/dsold(2))
721        enddo
722        i0 = i0 + int(dsnew(1)/dsold(1))
723        enddo
724      CASE (3)
725        i0 = ind_gmin(1)
726        do i = ind_newmin(1),ind_newmax(1)
727        j0 = ind_gmin(2)
728        do j = ind_newmin(2),ind_newmax(2)
729        k0 = ind_gmin(3)
730        do k = ind_newmin(3),ind_newmax(3)
731           New_Var % var % array3(i,j,k) =
732     &                  Old_Var % var % array3(i0,j0,k0)
733           New_Var % var % restore3D(i,j,k) = 1   
734                     k0 = k0 + int(dsnew(3)/dsold(3))
735        enddo
736        j0 = j0 + int(dsnew(2)/dsold(2))
737        enddo
738        i0 = i0 + int(dsnew(1)/dsold(1))
739        enddo
740      CASE (4)
741        i0 = ind_gmin(1)
742        do i = ind_newmin(1),ind_newmax(1)
743        j0 = ind_gmin(2)
744        do j = ind_newmin(2),ind_newmax(2)
745        k0 = ind_gmin(3)
746        do k = ind_newmin(3),ind_newmax(3)
747        l0 = ind_gmin(4)
748        do l = ind_newmin(4),ind_newmax(4) 
749           New_Var % var % array4(i,j,k,l) =
750     &                        Old_Var % var % array4(i0,j0,k0,l0)
751           New_Var % var % restore4D(i,j,k,l) = 1   
752        l0 = l0 + int(dsnew(4)/dsold(4))
753        enddo
754        k0 = k0 + int(dsnew(3)/dsold(3))
755        enddo
756        j0 = j0 + int(dsnew(2)/dsold(2))
757        enddo
758        i0 = i0 + int(dsnew(1)/dsold(1))
759        enddo
760      CASE (5)
761        i0 = ind_gmin(1)
762        do i = ind_newmin(1),ind_newmax(1)
763        j0 = ind_gmin(2)
764        do j = ind_newmin(2),ind_newmax(2)
765        k0 = ind_gmin(3)
766        do k = ind_newmin(3),ind_newmax(3)
767        l0 = ind_gmin(4)
768        do l = ind_newmin(4),ind_newmax(4) 
769        m0 = ind_gmin(5)
770        do m = ind_newmin(5),ind_newmax(5)
771           New_Var % var % array5(i,j,k,l,m) =
772     &                        Old_Var % var % array5(i0,j0,k0,l0,m0)
773           New_Var % var % restore5D(i,j,k,l,m) = 1
774        m0 = m0 + int(dsnew(5)/dsold(5)) 
775        enddo
776        l0 = l0 + int(dsnew(4)/dsold(4))
777        enddo
778        k0 = k0 + int(dsnew(3)/dsold(3))
779        enddo
780        j0 = j0 + int(dsnew(2)/dsold(2))
781        enddo
782        i0 = i0 + int(dsnew(1)/dsold(1))
783        enddo
784      CASE (6)
785        i0 = ind_gmin(1)
786        do i = ind_newmin(1),ind_newmax(1)
787        j0 = ind_gmin(2)
788        do j = ind_newmin(2),ind_newmax(2)
789        k0 = ind_gmin(3)
790        do k = ind_newmin(3),ind_newmax(3)
791        l0 = ind_gmin(4)
792        do l = ind_newmin(4),ind_newmax(4) 
793        m0 = ind_gmin(5)
794        do m = ind_newmin(5),ind_newmax(5)
795        n0 = ind_gmin(6)
796        do n = ind_newmin(6),ind_newmax(6)
797           New_Var % var % array6(i,j,k,l,m,n) =
798     &                        Old_Var % var % array6(i0,j0,k0,l0,m0,n0)
799           New_Var % var % restore6D(i,j,k,l,m,n) = 1
800        n0 = n0 + int(dsnew(6)/dsold(6)) 
801        enddo
802        m0 = m0 + int(dsnew(5)/dsold(5)) 
803        enddo
804        l0 = l0 + int(dsnew(4)/dsold(4))
805        enddo
806        k0 = k0 + int(dsnew(3)/dsold(3))
807        enddo
808        j0 = j0 + int(dsnew(2)/dsold(2))
809        enddo
810        i0 = i0 + int(dsnew(1)/dsold(1))
811        enddo
812      END SELECT
813C           
814      Return
815C
816C
817      End Subroutine Agrif_CopynD                   
818C
819C
820C
821      End module Agrif_Save
Note: See TracBrowser for help on using the repository browser.