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