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

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

importing AGRIF vendor

File size: 34.2 KB
Line 
1!
2! $Id: modarrays.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_Arrays
26C     
27      Module Agrif_Arrays
28      Use Agrif_Types
29C
30      implicit none
31C     
32      Contains
33C     **************************************************************************
34CCC   Subroutine Agrif_Childbounds
35C     **************************************************************************
36C
37      Subroutine Agrif_Childbounds(nbdim,lboundloc,uboundloc,
38     &                 pttab,petab,pttruetab,cetruetab,memberin)
39C
40CCC   Description:
41CCC   Subroutine calculating the global indices of the child grid
42C
43C
44C     Declarations:
45C
46
47C
48C     Arguments
49      INTEGER :: nbdim
50      INTEGER,DIMENSION(nbdim) :: lboundloc,uboundloc
51      INTEGER,DIMENSION(nbdim) :: pttab,petab,pttruetab,cetruetab
52      LOGICAL :: memberin
53C
54C     Local variables
55      INTEGER :: i,lbglob,ubglob
56C
57#ifdef AGRIF_MPI
58      INTEGER :: indglob1,indglob2
59#endif
60C
61C
62      do i = 1,nbdim
63C
64        lbglob = lboundloc(i)
65        ubglob = uboundloc(i)
66C
67#ifdef AGRIF_MPI
68C
69        Call AGRIF_InvLoc(lbglob,Agrif_ProcRank,i,indglob1)
70C
71        Call AGRIF_InvLoc(ubglob,Agrif_ProcRank,i,indglob2)
72C
73        pttruetab(i) = max(pttab(i),indglob1)       
74C
75        cetruetab(i) = min(petab(i),indglob2)                 
76C
77#else
78C
79        pttruetab(i) = max(pttab(i),lbglob)       
80C
81        cetruetab(i) = min(petab(i),ubglob)
82C
83#endif
84C
85      enddo
86
87      memberin = .TRUE.
88
89      do i=1,nbdim
90        IF (cetruetab(i) < pttruetab(i)) THEN
91          memberin = .FALSE.
92          EXIT
93        ENDIF
94      enddo
95C
96      Return
97C
98C
99      End Subroutine Agrif_Childbounds
100C
101C
102C     **************************************************************************
103CCC   Subroutine Agrif_nbdim_Get_bound
104C     **************************************************************************
105C
106      Subroutine Agrif_nbdim_Get_bound(Variable,
107     &                           lower,upper,indice,nbdim)
108C
109CCC   Description:
110CCC   This subroutine is used to get the lower and the upper boundaries of a
111C     table. Output datas are scalar.
112C
113C     Declarations:
114C     
115     
116C
117C     Arguments     
118C
119      ! we want extract boundaries of this table
120      TYPE(AGRIF_Variable), Pointer :: Variable   
121      INTEGER              :: lower,upper ! output data
122      ! direction in wich we want to know the dimension
123      INTEGER              :: indice     
124      INTEGER              :: nbdim       ! dimension of the table
125C
126C     Local variables
127C
128      SELECT CASE (nbdim)
129      CASE (1)
130           lower = lbound(Variable % array1,indice)
131           upper = ubound(Variable % array1,indice)
132      CASE (2)
133           lower = lbound(Variable % array2,indice)
134           upper = ubound(Variable % array2,indice)
135      CASE (3)
136           lower = lbound(Variable % array3,indice)
137           upper = ubound(Variable % array3,indice)
138      CASE (4)
139           lower = lbound(Variable % array4,indice)
140           upper = ubound(Variable % array4,indice)
141      CASE (5)
142           lower = lbound(Variable % array5,indice)
143           upper = ubound(Variable % array5,indice)
144      CASE (6)
145           lower = lbound(Variable % array6,indice)
146           upper = ubound(Variable % array6,indice)
147      END SELECT
148C
149      return
150C
151      End Subroutine Agrif_nbdim_Get_bound       
152C
153C
154C     **************************************************************************
155CCC   Subroutine Agrif_Get_bound_dimension
156C     **************************************************************************
157C
158      Subroutine Agrif_nbdim_Get_bound_dimension(Variable,
159     &                              lower,upper,nbdim)
160C
161CCC   Description:
162CCC   This subroutine is used to get the lower and the upper boundaries of a
163C        table. Output datas are scalar.
164C
165C     Declarations:
166C     
167     
168C
169C     Arguments     
170C
171      ! we want extract boundaries of this table
172      TYPE(AGRIF_Variable), Pointer     :: Variable   
173      INTEGER                  :: nbdim       ! dimension of the table
174      INTEGER,DIMENSION(nbdim) :: lower,upper ! output data
175C
176C     Local variables       
177C
178      lower = Variable % lb(1:nbdim)
179      upper = Variable % ub(1:nbdim)
180      return
181C
182      End Subroutine Agrif_nbdim_Get_bound_dimension     
183     
184C     **************************************************************************
185CCC   Subroutine Agrif_nbdim_allocation
186C     **************************************************************************
187C
188      Subroutine Agrif_nbdim_allocation(Variable,inf,sup,nbdim)
189C
190CCC   Description:
191CCC   This subroutine is used to Allocate the table Variable
192C
193C     Declarations:
194C     
195     
196C
197C     Arguments     
198C
199      TYPE(AGRIF_Variable), Pointer     :: Variable   
200      INTEGER                  :: nbdim       ! dimension of the table
201      INTEGER,DIMENSION(nbdim) :: inf,sup
202C
203C     Local variables       
204C
205      SELECT CASE (nbdim)
206      CASE (1)
207         allocate(Variable%array1(
208     &            inf(1):sup(1)))
209      CASE (2)
210          allocate(Variable%array2(
211     &            inf(1):sup(1),
212     &            inf(2):sup(2)))
213      CASE (3)
214         allocate(Variable%array3(
215     &            inf(1):sup(1),
216     &            inf(2):sup(2),
217     &            inf(3):sup(3)))
218      CASE (4)
219         allocate(Variable%array4(
220     &            inf(1):sup(1),
221     &            inf(2):sup(2),
222     &            inf(3):sup(3),
223     &            inf(4):sup(4)))
224      CASE (5)
225         allocate(Variable%array5(
226     &            inf(1):sup(1),
227     &            inf(2):sup(2),
228     &            inf(3):sup(3),
229     &            inf(4):sup(4),
230     &            inf(5):sup(5)))
231      CASE (6)
232         allocate(Variable%array6(
233     &            inf(1):sup(1),
234     &            inf(2):sup(2),
235     &            inf(3):sup(3),
236     &            inf(4):sup(4),
237     &            inf(5):sup(5),
238     &            inf(6):sup(6)))
239      END SELECT
240C
241      return
242C
243      End Subroutine Agrif_nbdim_allocation
244C
245C
246C     **************************************************************************
247CCC   Subroutine Agrif_nbdim_deallocation
248C     **************************************************************************
249C
250      Subroutine Agrif_nbdim_deallocation(Variable,nbdim)
251C
252CCC   Description:
253CCC   This subroutine is used to give the same value to the table Variable
254C
255C     Declarations:
256C     
257     
258C
259C     Arguments     
260C
261      TYPE(AGRIF_Variable), Pointer     :: Variable   
262      INTEGER                  :: nbdim       ! dimension of the table
263C
264C     Local variables       
265C
266
267      SELECT CASE (nbdim)
268      CASE (1)
269         Deallocate(Variable%array1)
270      CASE (2)
271         Deallocate(Variable%array2)
272      CASE (3)
273         Deallocate(Variable%array3)
274      CASE (4)
275         Deallocate(Variable%array4)
276      CASE (5)
277         Deallocate(Variable%array5)
278      CASE (6)
279         Deallocate(Variable%array6)
280      END SELECT
281C
282      return
283C
284      End Subroutine Agrif_nbdim_deallocation
285C
286C
287C     **************************************************************************
288CCC   Subroutine Agrif_nbdim_Full_VarEQreal
289C     **************************************************************************
290C
291      Subroutine Agrif_nbdim_Full_VarEQreal(Variable,Value,nbdim)
292C
293CCC   Description:
294CCC   This subroutine is used to get the lower and the upper boundaries of a
295C        table. Output datas are scalar.
296C
297C     Declarations:
298C     
299     
300C
301C     Arguments     
302C
303      TYPE(AGRIF_Variable), Pointer :: Variable   
304      REAL                 :: Value       
305      INTEGER              :: nbdim       ! dimension of the table
306C
307C     Local variables       
308C
309      SELECT CASE (nbdim)
310      CASE (1)
311        Variable%array1 = Value     
312      CASE (2)
313        Variable%array2 = Value
314      CASE (3)
315        Call Agrif_set_tozero3D(Variable%array3)
316!        Variable%array3 = Value
317      CASE (4)
318        Variable%array4 = Value
319      CASE (5)
320        Variable%array5 = Value
321      CASE (6)
322        Variable%array6 = Value
323      END SELECT
324C
325      return
326C
327      End Subroutine Agrif_nbdim_Full_VarEQreal   
328     
329      Subroutine Agrif_set_tozero3D(tab3D)
330      real,dimension(:,:,:),target :: tab3D
331     
332      tab3D = 0.
333     
334      end subroutine agrif_set_tozero3D   
335C
336C
337#if !defined AGRIF_MPI
338C     **************************************************************************
339CCC   Subroutine Agrif_nbdim_VarEQreal
340C     **************************************************************************
341C
342      Subroutine Agrif_nbdim_VarEQreal(Variable,inf,sup,Value,nbdim)
343C
344CCC   Description:
345CCC   This subroutine is used to give the same value to a part of 
346C        the table Variable
347C
348C     Declarations:
349C     
350     
351C
352C     Arguments     
353C
354      TYPE(AGRIF_Variable), Pointer :: Variable   
355      REAL                 :: Value       
356      INTEGER              :: nbdim       ! dimension of the table
357      INTEGER,DIMENSION(nbdim) :: inf,sup
358C
359C     Local variables       
360C
361      SELECT CASE (nbdim)
362      CASE (1)
363         Variable%array1(
364     &             inf(1):sup(1)
365     &             )  = Value
366      CASE (2)
367         Variable%array2(
368     &             inf(1):sup(1),
369     &             inf(2):sup(2)
370     &             )  = Value
371      CASE (3)
372         Variable%array3(
373     &             inf(1):sup(1),
374     &             inf(2):sup(2),
375     &             inf(3):sup(3)
376     &             )  = Value
377      CASE (4)
378         Variable%array4(
379     &             inf(1):sup(1),
380     &             inf(2):sup(2),
381     &             inf(3):sup(3),
382     &             inf(4):sup(4)
383     &             )  = Value
384      CASE (5)
385         Variable%array5(
386     &             inf(1):sup(1),
387     &             inf(2):sup(2),
388     &             inf(3):sup(3),
389     &             inf(4):sup(4),
390     &             inf(5):sup(5)
391     &             )  = Value
392      CASE (6)
393         Variable%array6(
394     &             inf(1):sup(1),
395     &             inf(2):sup(2),
396     &             inf(3):sup(3),
397     &             inf(4):sup(4),
398     &             inf(5):sup(5),
399     &             inf(6):sup(6)
400     &             )  = Value
401      END SELECT
402C
403      return
404C
405      End Subroutine Agrif_nbdim_VarEQreal       
406#endif
407C
408C
409C
410C     **************************************************************************
411CCC   Subroutine Agrif_nbdim_VarEQvar
412C     **************************************************************************
413C
414      Subroutine Agrif_nbdim_VarEQvar(Variable,inf,sup,
415     &                                Variable2,inf2,sup2,
416     &                                nbdim)
417C
418CCC   Description:
419CCC   This subroutine is used to give the value of a part of the table 
420C        Variable2 to the table Variable
421C
422C     Declarations:
423C     
424     
425C
426C     Arguments     
427C
428      TYPE(AGRIF_Variable), Pointer     :: Variable
429      TYPE(AGRIF_Variable), Pointer     :: Variable2
430      INTEGER                  :: nbdim       ! dimension of the table
431      INTEGER,DIMENSION(nbdim) :: inf,sup
432      INTEGER,DIMENSION(nbdim) :: inf2,sup2
433C
434C     Local variables       
435C
436      SELECT CASE (nbdim)
437      CASE (1)
438         Variable%array1(inf(1):sup(1)) = 
439     &         Variable2%array1(inf2(1):sup2(1))
440      CASE (2)
441     
442      Call Agrif_Copy_2d(Variable%array2,Variable2%array2,
443     &  lbound(Variable%array2),
444     &  lbound(Variable2%array2),
445     &  inf,sup,inf2,sup2)
446         
447      CASE (3)
448
449      Call Agrif_Copy_3d(Variable%array3,Variable2%array3,
450     &  lbound(Variable%array3),
451     &  lbound(Variable2%array3),
452     &  inf,sup,inf2,sup2)
453
454      CASE (4)
455     
456      Call Agrif_Copy_4d(Variable%array4,Variable2%array4,
457     &  lbound(Variable%array4),
458     &  lbound(Variable2%array4),
459     &  inf,sup,inf2,sup2)
460     
461      CASE (5)
462        Variable%array5(inf(1):sup(1),
463     &                         inf(2):sup(2), 
464     &                         inf(3):sup(3),
465     &                         inf(4):sup(4), 
466     &                         inf(5):sup(5)) = 
467     &         Variable2%array5(inf2(1):sup2(1),
468     &                          inf2(2):sup2(2),
469     &                          inf2(3):sup2(3),
470     &                          inf2(4):sup2(4),
471     &                          inf2(5):sup2(5))
472      CASE (6)
473        Variable%array6(inf(1):sup(1),
474     &                         inf(2):sup(2),
475     &                         inf(3):sup(3),
476     &                         inf(4):sup(4),
477     &                         inf(5):sup(5),
478     &                         inf(6):sup(6)) = 
479     &         Variable2%array6(inf2(1):sup2(1),
480     &                          inf2(2):sup2(2),
481     &                          inf2(3):sup2(3),
482     &                          inf2(4):sup2(4),
483     &                          inf2(5):sup2(5),
484     &                          inf2(6):sup2(6))
485      END SELECT
486C
487      return
488C
489      End Subroutine Agrif_nbdim_VarEQvar
490C
491C     **************************************************************************
492CCC   Subroutine Agrif_nbdim_Full_VarEQvar
493C     **************************************************************************
494C
495      Subroutine Agrif_nbdim_Full_VarEQvar(Variable,Variable2,
496     &                                nbdim)
497C
498CCC   Description:
499CCC   This subroutine is used to give the value of the table Variable2 
500C        to the table Variable
501C
502C     Declarations:
503C     
504     
505C
506C     Arguments     
507C
508      TYPE(AGRIF_Variable), Pointer     :: Variable
509      TYPE(AGRIF_Variable), Pointer     :: Variable2
510      INTEGER                  :: nbdim       ! dimension of the table
511C
512C     Local variables       
513C
514      SELECT CASE (nbdim)
515      CASE (1)
516          Variable%array1 = Variable2%array1
517      CASE (2)
518          Variable%array2 = Variable2%array2
519      CASE (3)
520          Variable%array3 = Variable2%array3
521      CASE (4)
522          Variable%array4 = Variable2%array4
523      CASE (5)
524          Variable%array5 = Variable2%array5
525      CASE (6)
526          Variable%array6 = Variable2%array6
527      END SELECT
528C
529      return
530C
531      End Subroutine Agrif_nbdim_Full_VarEQvar
532C
533C
534
535C     **************************************************************************
536CCC   Subroutine GiveAgrif_SpecialValueToTab_mpi
537C     **************************************************************************
538C
539      Subroutine GiveAgrif_SpecialValueToTab_mpi(Variable1,Variable2,
540     &                  bound1,lower,upper,Value,nbdim)
541C
542CCC   Description:
543CCC   
544C
545C     Declarations:
546C     
547     
548C
549C     Arguments     
550C
551      TYPE(AGRIF_VARIABLE), Pointer    :: Variable1
552      TYPE(AGRIF_VARIABLE), Pointer    :: Variable2
553      INTEGER                  :: nbdim
554      INTEGER,DIMENSION(:,:,:) :: bound1
555      INTEGER,DIMENSION(nbdim) :: lower,upper
556      REAL                     :: Value
557C
558C     Local variables       
559C
560      SELECT CASE (nbdim)
561      CASE (1)
562             Where (Variable1 % array1(
563     &           bound1(1,1,2):bound1(1,2,2)) 
564     &            == Value)
565             Variable2 % array1(bound1(1,1,1):bound1(1,2,1))
566     &                        = Value
567C     
568              End Where
569      CASE (2)
570             Where (Variable1 % array2(
571     &           bound1(1,1,2):bound1(1,2,2),
572     &           bound1(2,1,2):bound1(2,2,2)) 
573     &            == Value)
574             Variable2 % array2(bound1(1,1,1):bound1(1,2,1),
575     &                       bound1(2,1,1):bound1(2,2,1))
576     &                        = Value
577C     
578              End Where
579      CASE (3)
580             Where (Variable1 % array3(
581     &           bound1(1,1,2):bound1(1,2,2),
582     &                       bound1(2,1,2):bound1(2,2,2),
583     &                       bound1(3,1,2):bound1(3,2,2)) 
584     &            == Value)
585             Variable2 % array3(bound1(1,1,1):bound1(1,2,1),
586     &                       bound1(2,1,1):bound1(2,2,1),
587     &                       bound1(3,1,1):bound1(3,2,1))
588     &                         = Value
589C     
590              End Where
591      CASE (4)
592             Where (Variable1 % array4(
593     &           bound1(1,1,2):bound1(1,2,2),
594     &                       bound1(2,1,2):bound1(2,2,2),
595     &                       bound1(3,1,2):bound1(3,2,2),
596     &                       bound1(4,1,2):bound1(4,2,2)) 
597     &            == Value)
598             Variable2 % array4(bound1(1,1,1):bound1(1,2,1),
599     &                       bound1(2,1,1):bound1(2,2,1),
600     &                       bound1(3,1,1):bound1(3,2,1),
601     &                       bound1(4,1,1):bound1(4,2,1))
602     &                        = Value
603C     
604              End Where
605      CASE (5)
606             Where (Variable1 % array5(
607     &           bound1(1,1,2):bound1(1,2,2),
608     &                       bound1(2,1,2):bound1(2,2,2),
609     &                       bound1(3,1,2):bound1(3,2,2),
610     &                       bound1(4,1,2):bound1(4,2,2),
611     &                       bound1(5,1,2):bound1(5,2,2)) 
612     &            == Value)
613             Variable2 % array5(bound1(1,1,1):bound1(1,2,1),
614     &                       bound1(2,1,1):bound1(2,2,1),
615     &                       bound1(3,1,1):bound1(3,2,1),
616     &                       bound1(4,1,1):bound1(4,2,1),
617     &                       bound1(5,1,1):bound1(5,2,1))
618     &                        = Value
619C     
620              End Where
621      CASE (6)
622             Where (Variable1 % array6(
623     &           bound1(1,1,2):bound1(1,2,2),
624     &                       bound1(2,1,2):bound1(2,2,2),
625     &                       bound1(3,1,2):bound1(3,2,2),
626     &                       bound1(4,1,2):bound1(4,2,2),
627     &                       bound1(5,1,2):bound1(5,2,2),
628     &                       bound1(6,1,2):bound1(6,2,2)) 
629     &            == Value)
630             Variable2 % array6(bound1(1,1,1):bound1(1,2,1),
631     &                       bound1(2,1,1):bound1(2,2,1),
632     &                       bound1(3,1,1):bound1(3,2,1),
633     &                       bound1(4,1,1):bound1(4,2,1),
634     &                       bound1(5,1,1):bound1(5,2,1),
635     &                       bound1(6,1,1):bound1(6,2,1))
636     &                        = Value
637C     
638              End Where
639      END SELECT
640C
641      return
642C
643      End Subroutine GiveAgrif_SpecialValueToTab_mpi   
644
645C     **************************************************************************
646CCC   Subroutine GiveAgrif_SpecialValueToTab
647C     **************************************************************************
648C
649      Subroutine GiveAgrif_SpecialValueToTab(Variable1,Variable2,
650     &                  lower,upper,Value,nbdim)
651C
652CCC   Description:
653CCC   
654C
655C     Declarations:
656C     
657     
658C
659C     Arguments     
660C
661      TYPE(AGRIF_VARIABLE), Pointer    :: Variable1
662      TYPE(AGRIF_VARIABLE), Pointer    :: Variable2
663      INTEGER                  :: nbdim
664      INTEGER,DIMENSION(nbdim) :: lower,upper
665      REAL                     :: Value
666C
667C     Local variables       
668C
669      SELECT CASE (nbdim)
670      CASE (1)
671             Where (Variable1 % array1(
672     &           lower(1):upper(1))
673     &            == Value)
674             Variable2 % array1(lower(1):upper(1))
675     &                        = Value
676C     
677              End Where
678      CASE (2)
679             Where (Variable1 % array2(
680     &           lower(1):upper(1),
681     &           lower(2):upper(2)) 
682     &            == Value)
683             Variable2 % array2(lower(1):upper(1),
684     &                          lower(2):upper(2))
685     &                        = Value
686C     
687              End Where
688      CASE (3)
689             Where (Variable1 % array3(
690     &           lower(1):upper(1),
691     &           lower(2):upper(2), 
692     &           lower(3):upper(3)) 
693     &            == Value)
694             Variable2 % array3(lower(1):upper(1),
695     &                          lower(2):upper(2),
696     &                          lower(3):upper(3))
697     &                         = Value
698C     
699              End Where
700      CASE (4)
701             Where (Variable1 % array4(
702     &           lower(1):upper(1),
703     &           lower(2):upper(2), 
704     &           lower(3):upper(3),
705     &           lower(4):upper(4)) 
706     &            == Value)
707             Variable2 % array4(lower(1):upper(1),
708     &                          lower(2):upper(2),
709     &                          lower(3):upper(3),
710     &                          lower(4):upper(4))
711     &                        = Value
712C     
713              End Where
714      CASE (5)
715             Where (Variable1 % array5(
716     &           lower(1):upper(1),
717     &           lower(2):upper(2),
718     &           lower(3):upper(3),
719     &           lower(4):upper(4),
720     &           lower(5):upper(5)) 
721     &            == Value)
722             Variable2 % array5(lower(1):upper(1),
723     &                          lower(2):upper(2),
724     &                          lower(3):upper(3),
725     &                          lower(4):upper(4),
726     &                          lower(5):upper(5))
727     &                        = Value
728C     
729              End Where
730      CASE (6)
731             Where (Variable1 % array6(
732     &           lower(1):upper(1),
733     &           lower(2):upper(2),
734     &           lower(2):upper(3),
735     &           lower(4):upper(4),
736     &           lower(5):upper(5),
737     &           lower(6):upper(6)) 
738     &            == Value)
739             Variable2 % array6(lower(1):upper(1),
740     &                          lower(2):upper(2),
741     &                          lower(3):upper(3),
742     &                          lower(4):upper(4),
743     &                          lower(5):upper(5),
744     &                          lower(6):upper(6))
745     &                        = Value
746C     
747              End Where
748      END SELECT
749C
750      return
751C
752      End Subroutine GiveAgrif_SpecialValueToTab   
753
754C
755C
756#ifdef AGRIF_MPI
757C     **************************************************************************
758CCC   Subroutine Where_ValTabToTab_mpi
759C     **************************************************************************
760C
761      Subroutine Where_ValTabToTab_mpi(
762     &                  Variable1,Variable2,
763     &                  lower,upper,Value,nbdim)
764C
765CCC   Description:
766CCC   
767C
768C     Declarations:
769C     
770     
771C
772C     Arguments     
773C
774      TYPE(AGRIF_VARIABLE), Pointer     :: Variable1
775      TYPE(AGRIF_VARIABLE), Pointer     :: Variable2
776      INTEGER                  :: nbdim
777      INTEGER,DIMENSION(nbdim) :: lower,upper
778      REAL                     :: Value
779      INTEGER :: i,j,k,l,m,n
780C
781C     Local variables       
782C
783      SELECT CASE (nbdim)
784      CASE (1)
785            DO i = lower(1),upper(1)
786              IF (variable1%array1(i) == Value) then
787                variable1%array1(i)=Variable2%array1(i)
788              ENDIF
789            ENDDO
790      CASE (2)
791            DO j = lower(2),upper(2)
792            DO i = lower(1),upper(1)
793              IF (variable1%array2(i,j) == Value) then
794                variable1%array2(i,j)=Variable2%array2(i,j)
795              ENDIF
796            ENDDO
797            ENDDO
798      CASE (3)
799            DO k = lower(3),upper(3)
800            DO j = lower(2),upper(2)
801            DO i = lower(1),upper(1)
802              IF (variable1%array3(i,j,k) == Value) then
803                variable1%array3(i,j,k)=Variable2%array3(i,j,k)
804              ENDIF
805            ENDDO
806            ENDDO
807            ENDDO
808      CASE (4)
809            DO l = lower(4),upper(4)
810            DO k = lower(3),upper(3)
811            DO j = lower(2),upper(2)
812            DO i = lower(1),upper(1)
813              IF (variable1%array4(i,j,k,l) == Value) then
814                variable1%array4(i,j,k,l)=Variable2%array4(i,j,k,l)
815              ENDIF
816            ENDDO
817            ENDDO
818            ENDDO
819            ENDDO
820      CASE (5)
821            DO m = lower(5),upper(5)
822            DO l = lower(4),upper(4)
823            DO k = lower(3),upper(3)
824            DO j = lower(2),upper(2)
825            DO i = lower(1),upper(1)
826              IF (variable1%array5(i,j,k,l,m) == Value) then
827              variable1%array5(i,j,k,l,m)=Variable2%array5(i,j,k,l,m)
828              ENDIF
829            ENDDO
830            ENDDO
831            ENDDO
832            ENDDO
833            ENDDO
834      CASE (6)
835            DO n = lower(6),upper(6)
836            DO m = lower(5),upper(5)
837            DO l = lower(4),upper(4)
838            DO k = lower(3),upper(3)
839            DO j = lower(2),upper(2)
840            DO i = lower(1),upper(1)
841              IF (variable1%array6(i,j,k,l,m,n) == Value) then
842            variable1%array6(i,j,k,l,m,n)=Variable2%array6(i,j,k,l,m,n)
843              ENDIF
844            ENDDO
845            ENDDO
846            ENDDO
847            ENDDO
848            ENDDO
849            ENDDO
850      END SELECT
851C
852      return
853C
854      End Subroutine Where_ValTabToTab_mpi   
855#endif
856
857C     **************************************************************************
858CCC   Subroutine PreProcessToInterpOrUpdate
859C     **************************************************************************
860C
861      Subroutine PreProcessToInterpOrUpdate(parent,child,
862     &             petab_Child,
863     &             pttab_Child,pttab_Parent,
864     &             s_Child,s_Parent,
865     &             ds_Child,ds_Parent,
866     &             nbdim)
867C
868CCC   Description:
869CCC   
870C
871C     Declarations:
872C     
873C     arguments                                   
874      TYPE(AGRIF_PVariable) :: parent   ! Variable on the parent grid
875      TYPE(AGRIF_PVariable) :: child    ! Variable on the child grid
876      INTEGER :: nbdim                 
877      INTEGER,DIMENSION(6) :: pttab_child 
878      INTEGER,DIMENSION(6) :: petab_child     
879      INTEGER,DIMENSION(6) :: pttab_parent 
880      TYPE(AGRIF_Variable), Pointer :: root ! Pointer on the variable of the
881                                            ! root grid
882      TYPE(Agrif_Grid), Pointer :: Agrif_Child_Gr,Agrif_Parent_Gr
883      REAL, DIMENSION(6) :: s_child,s_parent
884      REAL, DIMENSION(6) :: ds_child,ds_parent
885C     locals variables
886      INTEGER :: n
887     
888C
889C     Arguments     
890C
891
892C
893C     Local variables       
894C
895      Agrif_Child_Gr => Agrif_Curgrid
896      Agrif_Parent_Gr => Agrif_Curgrid % parent
897C
898      root => child % var % root_var 
899C
900C     Number of dimensions of the current grid
901      nbdim = root % nbdim
902C     
903      do n=1,nbdim
904C           
905        Select case(root % interptab(n))
906C
907C       Value of interptab(n) can be either x,y,z or N for a no space 
908C       DIMENSION           
909C
910C         The DIMENSION is 'x'
911          case('x')
912C
913            pttab_Child(n) = root % point(1)
914C           
915            pttab_Parent(n) = root % point(1)
916C       
917            s_Child(n) = Agrif_Child_Gr % Agrif_x(1)
918C
919            s_Parent(n) = Agrif_Parent_Gr % Agrif_x(1)
920C       
921            ds_Child(n) = Agrif_Child_Gr % Agrif_d(1)
922C
923            ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(1)
924C                     
925            if (root % posvar(n).EQ.1) then
926C         
927              petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(1)
928C       
929              else
930C         
931                petab_Child(n) = pttab_Child(n) + 
932     &                              Agrif_Child_Gr%nb(1) - 1
933C         
934                s_Child(n) = s_Child(n) + ds_Child(n)/2.
935C
936                s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
937C       
938            endif                 
939C
940C         The DIMENSION is 'y'
941          case('y')
942C
943            pttab_Child(n) = root % point(2)
944C           
945            pttab_Parent(n) = root % point(2)
946C       
947            s_Child(n) = Agrif_Child_Gr % Agrif_x(2)
948C
949            s_Parent(n) = Agrif_Parent_Gr % Agrif_x(2) 
950C       
951            ds_Child(n) = Agrif_Child_Gr % Agrif_d(2)
952C
953            ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(2)
954C                     
955            if (root % posvar(n).EQ.1) then
956C         
957             petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(2)
958C         
959              else
960C         
961                petab_Child(n) = pttab_Child(n) + 
962     &                       Agrif_Child_Gr%nb(2) - 1
963C         
964                s_Child(n) = s_Child(n) + ds_Child(n)/2.
965C
966                s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
967C       
968            endif
969           
970C
971C         The DIMENSION is 'z'                           
972          case('z')
973C
974            pttab_Child(n) = root % point(3)
975C           
976            pttab_Parent(n) = root % point(3)
977C       
978            s_Child(n) = Agrif_Child_Gr % Agrif_x(3)
979C
980            s_Parent(n) = Agrif_Parent_Gr % Agrif_x(3)
981C       
982            ds_Child(n) = Agrif_Child_Gr % Agrif_d(3)
983C
984            ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(3)
985C                     
986            if (root % posvar(n).EQ.1) then
987C         
988             petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(3)
989C         
990              else
991C         
992                petab_Child(n) = pttab_Child(n) + 
993     &                      Agrif_Child_Gr%nb(3) - 1
994C
995                s_Child(n) = s_Child(n) + ds_Child(n)/2.
996C
997                s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
998C       
999            endif       
1000C 
1001C         The DIMENSION is not space                           
1002          case('N')
1003C
1004C         The next coefficients are calculated in order to do a simple copy of 
1005C         values of the grid variable when the procedure of interpolation is 
1006C         called for this DIMENSION
1007C     
1008            Call Agrif_nbdim_Get_bound(child % var,
1009     &                           pttab_Child(n),petab_Child(n),n,nbdim)
1010C
1011C           No interpolation but only a copy of the values of the grid variable
1012C
1013            pttab_Parent(n) = pttab_Child(n)
1014C             
1015            s_Child(n)=0.
1016C     
1017            s_Parent(n)=0. 
1018C     
1019            ds_Child(n)=1.
1020C     
1021            ds_Parent(n)=1.
1022C
1023        End select
1024C           
1025      enddo     
1026C
1027      return
1028C
1029      End Subroutine PreProcessToInterpOrUpdate     
1030
1031#ifdef AGRIF_MPI
1032C
1033C     **************************************************************************
1034CCC   Subroutine GetLocalBoundaries
1035C     **************************************************************************
1036C
1037      Subroutine GetLocalBoundaries(tab1,tab2,i,lb,ub,deb,fin)
1038C
1039CCC   Descritpion:
1040C 
1041C
1042C     Declarations:
1043C
1044
1045C
1046C
1047C     Scalar arguments
1048      INTEGER  ::  tab1,tab2
1049      INTEGER  ::  i
1050      INTEGER  ::  lb,ub
1051      INTEGER  ::  deb,fin
1052C
1053C     Local scalars
1054      INTEGER  ::  imin,imax
1055      INTEGER  ::  i1,i2
1056C
1057C
1058      Call AGRIF_InvLoc(lb,AGRIF_ProcRank,i,imin)
1059C
1060      Call AGRIF_InvLoc(ub,AGRIF_ProcRank,i,imax)
1061C
1062C
1063      if (imin > tab2) then
1064C
1065          i1 = imax - imin
1066C
1067        else
1068C
1069          i1 = max(tab1 - imin,0)
1070C
1071      endif
1072C
1073      if (imax < tab1) then
1074C
1075          i2 = -(imax - imin)
1076C
1077        else
1078C
1079          i2 = min(tab2 - imax,0)
1080C
1081      endif
1082C
1083      deb = lb + i1
1084C
1085      fin = ub + i2
1086C
1087C
1088      End Subroutine GetLocalBoundaries
1089C
1090#endif
1091C
1092C
1093#ifdef AGRIF_MPI
1094C
1095C
1096C     **************************************************************************
1097CCC   Subroutine Agrif_GlobtoLocInd2
1098C     **************************************************************************
1099C
1100      Subroutine Agrif_GlobtoLocInd2(tabarray,lboundl,uboundl,tab1,tab2,
1101     &                              nbdim,rank,member)
1102C
1103CCC   Description:
1104CCC   For a global index located on the current processor, tabarray gives the 
1105CCC   corresponding local index   
1106C
1107C
1108C     Declarations:
1109C
1110
1111C
1112C     Arguments
1113      INTEGER :: nbdim
1114      INTEGER,DIMENSION(nbdim) :: tab1,tab2
1115      INTEGER,DIMENSION(nbdim,2,2 ) :: tabarray
1116      INTEGER,DIMENSION(nbdim) :: lboundl,uboundl
1117      INTEGER :: rank
1118      LOGICAL :: member
1119C   
1120C     Local variables
1121      INTEGER :: i,i1,k
1122      INTEGER :: nbloc(nbdim)
1123C
1124C
1125      tabarray(:,1,:) =  HUGE(1)
1126      tabarray(:,2,:) =  -HUGE(1)
1127
1128      nbloc = 0
1129C       
1130      do i = 1,nbdim
1131C       
1132        Call Agrif_Invloc(lboundl(i),rank,i,i1)
1133       
1134        do k=tab1(i)+lboundl(i)-i1,tab2(i)+lboundl(i)-i1
1135          IF ((k .GE. lboundl(i)) .AND. (k.LE.uboundl(i))) THEN
1136            nbloc(i) = 1
1137            tabarray(i,1,1) = min(tabarray(i,1,1),k-lboundl(i)+i1)
1138            tabarray(i,2,1) = max(tabarray(i,2,1),k-lboundl(i)+i1)
1139       
1140            tabarray(i,1,2) = min(tabarray(i,1,2),k)
1141            tabarray(i,2,2) = max(tabarray(i,2,2),k)
1142          ENDIF
1143        enddo
1144C
1145      enddo
1146
1147      member = .FALSE.
1148      IF (sum(nbloc) == nbdim) member = .TRUE.
1149C
1150      Return
1151C
1152C
1153      End Subroutine Agrif_GlobtoLocInd2
1154C
1155#endif     
1156
1157      Subroutine Agrif_Copy_2d(tabout,tabin,l,m,inf,sup,inf2,sup2)
1158      integer,dimension(2) :: l,m,inf,sup,inf2,sup2
1159      real,target,dimension(l(1):,l(2):) :: tabout
1160      real,target,dimension(m(1):,m(2):) :: tabin
1161          tabout(inf(1):sup(1),
1162     &                         inf(2):sup(2)) = 
1163     &         tabin(inf2(1):sup2(1),
1164     &                          inf2(2):sup2(2))
1165      End Subroutine Agrif_Copy_2d
1166     
1167      Subroutine Agrif_Copy_3d(tabout,tabin,l,m,inf,sup,inf2,sup2)
1168      integer,dimension(3) :: l,m,inf,sup,inf2,sup2
1169      real,target,dimension(l(1):,l(2):,l(3):) :: tabout
1170      real,target,dimension(m(1):,m(2):,m(3):) :: tabin
1171          tabout(inf(1):sup(1),
1172     &                         inf(2):sup(2), 
1173     &                         inf(3):sup(3)) = 
1174     &         tabin(inf2(1):sup2(1),
1175     &                          inf2(2):sup2(2),
1176     &                          inf2(3):sup2(3))
1177      End Subroutine Agrif_Copy_3d
1178     
1179      Subroutine Agrif_Copy_4d(tabout,tabin,l,m,inf,sup,inf2,sup2)
1180      integer,dimension(4) :: l,m,inf,sup,inf2,sup2
1181      real,target,dimension(l(1):,l(2):,l(3):,l(4):) :: tabout
1182      real,target,dimension(m(1):,m(2):,m(3):,m(4):) :: tabin
1183          tabout(inf(1):sup(1),
1184     &                         inf(2):sup(2), 
1185     &                         inf(3):sup(3), 
1186     &                         inf(4):sup(4)) = 
1187     &         tabin(inf2(1):sup2(1),
1188     &                          inf2(2):sup2(2),
1189     &                          inf2(3):sup2(3),
1190     &                          inf2(4):sup2(4))
1191      End Subroutine Agrif_Copy_4d     
1192
1193      End Module Agrif_Arrays
Note: See TracBrowser for help on using the repository browser.