source: trunk/AGRIF/AGRIF_FILES/modarrays.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: 40.0 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_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      SELECT CASE (nbdim)
179      CASE (1)
180           lower = lbound(Variable % array1)
181           upper = ubound(Variable % array1)
182      CASE (2)
183           lower = lbound(Variable % array2)
184           upper = ubound(Variable % array2)
185      CASE (3)
186           lower = lbound(Variable % array3)
187           upper = ubound(Variable % array3)
188      CASE (4)
189           lower = lbound(Variable % array4)
190           upper = ubound(Variable % array4)
191      CASE (5)
192           lower = lbound(Variable % array5)
193           upper = ubound(Variable % array5)
194      CASE (6)
195           lower = lbound(Variable % array6)
196           upper = ubound(Variable % array6)
197      END SELECT
198C
199      return
200C
201      End Subroutine Agrif_nbdim_Get_bound_dimension     
202     
203C     **************************************************************************
204CCC   Subroutine Agrif_nbdim_allocation
205C     **************************************************************************
206C
207      Subroutine Agrif_nbdim_allocation(Variable,inf,sup,nbdim)
208C
209CCC   Description:
210CCC   This subroutine is used to Allocate the table Variable
211C
212C     Declarations:
213C     
214     
215C
216C     Arguments     
217C
218      TYPE(AGRIF_Variable), Pointer     :: Variable   
219      INTEGER                  :: nbdim       ! dimension of the table
220      INTEGER,DIMENSION(nbdim) :: inf,sup
221C
222C     Local variables       
223C
224      SELECT CASE (nbdim)
225      CASE (1)
226         allocate(Variable%array1(
227     &            inf(1):sup(1)))
228      CASE (2)
229          allocate(Variable%array2(
230     &            inf(1):sup(1),
231     &            inf(2):sup(2)))
232      CASE (3)
233         allocate(Variable%array3(
234     &            inf(1):sup(1),
235     &            inf(2):sup(2),
236     &            inf(3):sup(3)))
237      CASE (4)
238         allocate(Variable%array4(
239     &            inf(1):sup(1),
240     &            inf(2):sup(2),
241     &            inf(3):sup(3),
242     &            inf(4):sup(4)))
243      CASE (5)
244         allocate(Variable%array5(
245     &            inf(1):sup(1),
246     &            inf(2):sup(2),
247     &            inf(3):sup(3),
248     &            inf(4):sup(4),
249     &            inf(5):sup(5)))
250      CASE (6)
251         allocate(Variable%array6(
252     &            inf(1):sup(1),
253     &            inf(2):sup(2),
254     &            inf(3):sup(3),
255     &            inf(4):sup(4),
256     &            inf(5):sup(5),
257     &            inf(6):sup(6)))
258      END SELECT
259C
260      return
261C
262      End Subroutine Agrif_nbdim_allocation
263C
264C
265C     **************************************************************************
266CCC   Subroutine Agrif_nbdim_deallocation
267C     **************************************************************************
268C
269      Subroutine Agrif_nbdim_deallocation(Variable,nbdim)
270C
271CCC   Description:
272CCC   This subroutine is used to give the same value to the table Variable
273C
274C     Declarations:
275C     
276     
277C
278C     Arguments     
279C
280      TYPE(AGRIF_Variable), Pointer     :: Variable   
281      INTEGER                  :: nbdim       ! dimension of the table
282C
283C     Local variables       
284C
285
286      SELECT CASE (nbdim)
287      CASE (1)
288         Deallocate(Variable%array1)
289      CASE (2)
290         Deallocate(Variable%array2)
291      CASE (3)
292         Deallocate(Variable%array3)
293      CASE (4)
294         Deallocate(Variable%array4)
295      CASE (5)
296         Deallocate(Variable%array5)
297      CASE (6)
298         Deallocate(Variable%array6)
299      END SELECT
300C
301      return
302C
303      End Subroutine Agrif_nbdim_deallocation
304C
305C
306C     **************************************************************************
307CCC   Subroutine Agrif_nbdim_Full_VarEQreal
308C     **************************************************************************
309C
310      Subroutine Agrif_nbdim_Full_VarEQreal(Variable,Value,nbdim)
311C
312CCC   Description:
313CCC   This subroutine is used to get the lower and the upper boundaries of a
314C        table. Output datas are scalar.
315C
316C     Declarations:
317C     
318     
319C
320C     Arguments     
321C
322      TYPE(AGRIF_Variable), Pointer :: Variable   
323      REAL                 :: Value       
324      INTEGER              :: nbdim       ! dimension of the table
325C
326C     Local variables       
327C
328      SELECT CASE (nbdim)
329      CASE (1)
330        Variable%array1 = Value     
331      CASE (2)
332        Variable%array2 = Value
333      CASE (3)
334        Variable%array3 = Value
335      CASE (4)
336        Variable%array4 = Value
337      CASE (5)
338        Variable%array5 = Value
339      CASE (6)
340        Variable%array6 = Value
341      END SELECT
342C
343      return
344C
345      End Subroutine Agrif_nbdim_Full_VarEQreal       
346C
347C
348#if !defined AGRIF_MPI
349C     **************************************************************************
350CCC   Subroutine Agrif_nbdim_VarEQreal
351C     **************************************************************************
352C
353      Subroutine Agrif_nbdim_VarEQreal(Variable,inf,sup,Value,nbdim)
354C
355CCC   Description:
356CCC   This subroutine is used to give the same value to a part of 
357C        the table Variable
358C
359C     Declarations:
360C     
361     
362C
363C     Arguments     
364C
365      TYPE(AGRIF_Variable), Pointer :: Variable   
366      REAL                 :: Value       
367      INTEGER              :: nbdim       ! dimension of the table
368      INTEGER,DIMENSION(nbdim) :: inf,sup
369C
370C     Local variables       
371C
372      SELECT CASE (nbdim)
373      CASE (1)
374         Variable%array1(
375     &             inf(1):sup(1)
376     &             )  = Value
377      CASE (2)
378         Variable%array2(
379     &             inf(1):sup(1),
380     &             inf(2):sup(2)
381     &             )  = Value
382      CASE (3)
383         Variable%array3(
384     &             inf(1):sup(1),
385     &             inf(2):sup(2),
386     &             inf(3):sup(3)
387     &             )  = Value
388      CASE (4)
389         Variable%array4(
390     &             inf(1):sup(1),
391     &             inf(2):sup(2),
392     &             inf(3):sup(3),
393     &             inf(4):sup(4)
394     &             )  = Value
395      CASE (5)
396         Variable%array5(
397     &             inf(1):sup(1),
398     &             inf(2):sup(2),
399     &             inf(3):sup(3),
400     &             inf(4):sup(4),
401     &             inf(5):sup(5)
402     &             )  = Value
403      CASE (6)
404         Variable%array6(
405     &             inf(1):sup(1),
406     &             inf(2):sup(2),
407     &             inf(3):sup(3),
408     &             inf(4):sup(4),
409     &             inf(5):sup(5),
410     &             inf(6):sup(6)
411     &             )  = Value
412      END SELECT
413C
414      return
415C
416      End Subroutine Agrif_nbdim_VarEQreal       
417#endif
418C
419C
420C
421C     **************************************************************************
422CCC   Subroutine Agrif_nbdim_VarEQvar
423C     **************************************************************************
424C
425      Subroutine Agrif_nbdim_VarEQvar(Variable,inf,sup,
426     &                                Variable2,inf2,sup2,
427     &                                nbdim)
428C
429CCC   Description:
430CCC   This subroutine is used to give the value of a part of the table 
431C        Variable2 to the table Variable
432C
433C     Declarations:
434C     
435     
436C
437C     Arguments     
438C
439      TYPE(AGRIF_Variable), Pointer     :: Variable
440      TYPE(AGRIF_Variable), Pointer     :: Variable2
441      INTEGER                  :: nbdim       ! dimension of the table
442      INTEGER,DIMENSION(nbdim) :: inf,sup
443      INTEGER,DIMENSION(nbdim) :: inf2,sup2
444C
445C     Local variables       
446C
447      SELECT CASE (nbdim)
448      CASE (1)
449         Variable%array1(inf(1):sup(1)) = 
450     &         Variable2%array1(inf2(1):sup2(1))
451      CASE (2)
452         Variable%array2(inf(1):sup(1),
453     &                         inf(2):sup(2)) = 
454     &         Variable2%array2(inf2(1):sup2(1),
455     &                          inf2(2):sup2(2))
456      CASE (3)
457         Variable%array3(inf(1):sup(1),
458     &                         inf(2):sup(2), 
459     &                         inf(3):sup(3)) = 
460     &         Variable2%array3(inf2(1):sup2(1),
461     &                          inf2(2):sup2(2),
462     &                          inf2(3):sup2(3))
463      CASE (4)
464        Variable%array4(inf(1):sup(1),
465     &                         inf(2):sup(2), 
466     &                         inf(3):sup(3),
467     &                         inf(4):sup(4)) = 
468     &         Variable2%array4(inf2(1):sup2(1),
469     &                          inf2(2):sup2(2),
470     &                          inf2(3):sup2(3),
471     &                          inf2(4):sup2(4))
472      CASE (5)
473        Variable%array5(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     &         Variable2%array5(inf2(1):sup2(1),
479     &                          inf2(2):sup2(2),
480     &                          inf2(3):sup2(3),
481     &                          inf2(4):sup2(4),
482     &                          inf2(5):sup2(5))
483      CASE (6)
484        Variable%array6(inf(1):sup(1),
485     &                         inf(2):sup(2),
486     &                         inf(3):sup(3),
487     &                         inf(4):sup(4),
488     &                         inf(5):sup(5),
489     &                         inf(6):sup(6)) = 
490     &         Variable2%array6(inf2(1):sup2(1),
491     &                          inf2(2):sup2(2),
492     &                          inf2(3):sup2(3),
493     &                          inf2(4):sup2(4),
494     &                          inf2(5):sup2(5),
495     &                          inf2(6):sup2(6))
496      END SELECT
497C
498      return
499C
500      End Subroutine Agrif_nbdim_VarEQvar
501C
502C     **************************************************************************
503CCC   Subroutine Agrif_nbdim_Full_VarEQvar
504C     **************************************************************************
505C
506      Subroutine Agrif_nbdim_Full_VarEQvar(Variable,Variable2,
507     &                                nbdim)
508C
509CCC   Description:
510CCC   This subroutine is used to give the value of the table Variable2 
511C        to the table Variable
512C
513C     Declarations:
514C     
515     
516C
517C     Arguments     
518C
519      TYPE(AGRIF_Variable), Pointer     :: Variable
520      TYPE(AGRIF_Variable), Pointer     :: Variable2
521      INTEGER                  :: nbdim       ! dimension of the table
522C
523C     Local variables       
524C
525      SELECT CASE (nbdim)
526      CASE (1)
527          Variable%array1 = Variable2%array1
528      CASE (2)
529          Variable%array2 = Variable2%array2
530      CASE (3)
531          Variable%array3 = Variable2%array3
532      CASE (4)
533          Variable%array4 = Variable2%array4
534      CASE (5)
535          Variable%array5 = Variable2%array5
536      CASE (6)
537          Variable%array6 = Variable2%array6
538      END SELECT
539C
540      return
541C
542      End Subroutine Agrif_nbdim_Full_VarEQvar
543C
544C
545C     **************************************************************************
546CCC   Subroutine Agrif_array2vector
547C     **************************************************************************
548C
549      Subroutine Agrif_array2vector(array,bounds,vector,nbdim)
550C
551CCC   Description:
552CCC   This subroutine is used to record the array into the vector
553C
554C     Declarations:
555C     
556     
557C
558C     Arguments     
559C
560      TYPE(AGRIF_Variable), Pointer       :: array
561      REAL, DIMENSION(:)         :: vector      ! Array used for the time
562      INTEGER                    :: nbdim       ! dimension of the table
563      INTEGER,DIMENSION(nbdim,2) :: bounds
564C
565C     Local variables       
566C
567      INTEGER                      :: nind,ir,jr,kr,lr,mr,nr
568C
569      SELECT CASE (nbdim)
570      CASE (1)
571         nind=0
572         do ir=bounds(1,1),bounds(1,2)
573            nind=nind+1
574            array%array1(ir) = vector(nind)
575         enddo       
576C
577      CASE (2)
578         nind=0
579          do jr=bounds(2,1),bounds(2,2)
580           do ir=bounds(1,1),bounds(1,2)
581               nind=nind+1
582               array%array2(ir,jr) = vector(nind)
583           enddo
584         enddo       
585C
586      CASE (3)
587         nind=0
588        do kr=bounds(3,1),bounds(3,2)
589           do jr=bounds(2,1),bounds(2,2)
590             do ir=bounds(1,1),bounds(1,2)
591                  nind=nind+1
592                  array%array3(ir,jr,kr) = vector(nind)
593             enddo
594           enddo
595         enddo     
596C
597      CASE (4)
598         nind=0
599        do lr=bounds(4,1),bounds(4,2)
600          do kr=bounds(3,1),bounds(3,2)
601             do jr=bounds(2,1),bounds(2,2)
602               do ir=bounds(1,1),bounds(1,2)
603                     nind=nind+1
604                     array%array4(ir,jr,kr,lr) = vector(nind)
605               enddo
606             enddo
607           enddo
608         enddo         
609C
610      CASE (5)
611         nind=0
612         do mr=bounds(5,1),bounds(5,2)
613         do lr=bounds(4,1),bounds(4,2)
614          do kr=bounds(3,1),bounds(3,2) 
615              do jr=bounds(2,1),bounds(2,2)
616                 do ir=bounds(1,1),bounds(1,2)
617                     nind=nind+1
618                     array%array5(ir,jr,kr,lr,mr) = vector(nind)
619                 enddo
620               enddo
621             enddo
622           enddo
623         enddo       
624C
625      CASE (6)
626         nind=0
627        do nr=bounds(6,1),bounds(6,2)
628          do mr=bounds(5,1),bounds(5,2)
629          do lr=bounds(4,1),bounds(4,2)
630           do kr=bounds(3,1),bounds(3,2)
631             do jr=bounds(2,1),bounds(2,2)
632                   do ir=bounds(1,1),bounds(1,2)
633                     nind=nind+1
634                     array%array6(ir,jr,kr,lr,mr,nr) = vector(nind)
635                   enddo
636                 enddo
637               enddo
638             enddo
639           enddo
640         enddo       
641        END SELECT
642C
643      return
644C
645      End Subroutine Agrif_array2vector
646C
647C
648C
649C     **************************************************************************
650CCC   Subroutine Agrif_vector2array
651C     **************************************************************************
652C
653      Subroutine Agrif_vector2array(vector,array,bounds,nbdim)
654C
655CCC   Description:
656CCC   This subroutine is used to record the array into the vector
657C
658C     Declarations:
659C     
660     
661C
662C     Arguments     
663C
664      TYPE(AGRIF_Variable), Pointer       :: array
665      REAL, DIMENSION(:)         :: vector      ! Array used for the time
666      INTEGER                    :: nbdim       ! dimension of the table
667      INTEGER,DIMENSION(nbdim,2) :: bounds
668C
669C     Local variables       
670C
671      INTEGER                      :: nind,ir,jr,kr,lr,mr,nr
672C
673      SELECT CASE (nbdim)
674      CASE (1)
675         nind=0
676         do ir=bounds(1,1),bounds(1,2)
677            nind=nind+1
678            vector(nind) = array%array1(ir)
679         enddo       
680C
681      CASE (2)
682         nind=0
683        do jr=bounds(2,1),bounds(2,2)
684           do ir=bounds(1,1),bounds(1,2)
685               nind=nind+1
686               vector(nind) = array%array2(ir,jr)
687           enddo
688         enddo     
689C
690      CASE (3)
691         nind=0
692        do kr=bounds(3,1),bounds(3,2)
693          do jr=bounds(2,1),bounds(2,2)
694             do ir=bounds(1,1),bounds(1,2)
695                  nind=nind+1
696                  vector(nind) = array%array3(ir,jr,kr)
697             enddo
698           enddo
699         enddo       
700C
701      CASE (4)
702         nind=0
703          do lr=bounds(4,1),bounds(4,2)
704           do kr=bounds(3,1),bounds(3,2)
705             do jr=bounds(2,1),bounds(2,2)
706               do ir=bounds(1,1),bounds(1,2)
707                     nind=nind+1
708                     vector(nind) = array%array4(ir,jr,kr,lr)
709               enddo
710             enddo
711           enddo
712         enddo         
713C
714      CASE (5)
715         nind=0
716         do mr=bounds(5,1),bounds(5,2)
717           do lr=bounds(4,1),bounds(4,2)
718            do kr=bounds(3,1),bounds(3,2) 
719              do jr=bounds(2,1),bounds(2,2)
720                 do ir=bounds(1,1),bounds(1,2)
721                     nind=nind+1
722                     vector(nind) = array%array5(ir,jr,kr,lr,mr)
723                 enddo
724               enddo
725             enddo
726           enddo
727         enddo   
728C
729      CASE (6)
730         nind=0
731        do nr=bounds(6,1),bounds(6,2)
732           do mr=bounds(5,1),bounds(5,2)
733             do lr=bounds(4,1),bounds(4,2)
734               do kr=bounds(3,1),bounds(3,2)
735                do jr=bounds(2,1),bounds(2,2)
736                   do ir=bounds(1,1),bounds(1,2)
737                     nind=nind+1
738                     vector(nind) = array%array6(ir,jr,kr,lr,mr,nr)
739                   enddo
740                 enddo
741               enddo
742             enddo
743           enddo
744         enddo       
745      END SELECT
746C
747      return
748C
749      End Subroutine Agrif_vector2array
750
751#ifdef AGRIF_MPI
752C     **************************************************************************
753CCC   Subroutine GiveAgrif_SpecialValueToTab_mpi
754C     **************************************************************************
755C
756      Subroutine GiveAgrif_SpecialValueToTab_mpi(Variable1,Variable2,
757     &                  bound1,lower,upper,Value,nbdim)
758C
759CCC   Description:
760CCC   
761C
762C     Declarations:
763C     
764     
765C
766C     Arguments     
767C
768      TYPE(AGRIF_VARIABLE), Pointer    :: Variable1
769      TYPE(AGRIF_VARIABLE), Pointer    :: Variable2
770      INTEGER                  :: nbdim
771      INTEGER,DIMENSION(:,:,:) :: bound1
772      INTEGER,DIMENSION(nbdim) :: lower,upper
773      REAL                     :: Value
774C
775C     Local variables       
776C
777      SELECT CASE (nbdim)
778      CASE (1)
779             Where (Variable1 % array1(
780     &           bound1(lower(1),1,2):bound1(upper(1),1,2)) 
781     &            == Value)
782             Variable2 % array1(lower(1):upper(1))
783     &                        = Value
784C     
785              End Where
786      CASE (2)
787             Where (Variable1 % array2(
788     &           bound1(lower(1),1,2):bound1(upper(1),1,2),
789     &           bound1(lower(2),2,2):bound1(upper(2),2,2)) 
790     &            == Value)
791             Variable2 % array2(lower(1):upper(1),
792     &                          lower(2):upper(2))
793     &                        = Value
794C     
795              End Where
796      CASE (3)
797             Where (Variable1 % array3(
798     &           bound1(lower(1),1,2):bound1(upper(1),1,2),
799     &           bound1(lower(2),2,2):bound1(upper(2),2,2), 
800     &           bound1(lower(3),3,2):bound1(upper(3),3,2)) 
801     &            == Value)
802             Variable2 % array3(lower(1):upper(1),
803     &                          lower(2):upper(2),
804     &                          lower(3):upper(3))
805     &                         = Value
806C     
807              End Where
808      CASE (4)
809             Where (Variable1 % array4(
810     &           bound1(lower(1),1,2):bound1(upper(1),1,2),
811     &           bound1(lower(2),2,2):bound1(upper(2),2,2), 
812     &           bound1(lower(3),3,2):bound1(upper(3),3,2),
813     &           bound1(lower(4),4,2):bound1(upper(4),4,2)) 
814     &            == Value)
815             Variable2 % array4(lower(1):upper(1),
816     &                          lower(2):upper(2),
817     &                          lower(3):upper(3),
818     &                          lower(4):upper(4))
819     &                        = Value
820C     
821              End Where
822      CASE (5)
823             Where (Variable1 % array5(
824     &           bound1(lower(1),1,2):bound1(upper(1),1,2),
825     &           bound1(lower(2),2,2):bound1(upper(2),2,2),
826     &           bound1(lower(3),3,2):bound1(upper(3),3,2),
827     &           bound1(lower(4),4,2):bound1(upper(4),4,2),
828     &           bound1(lower(5),5,2):bound1(upper(5),5,2)) 
829     &            == Value)
830             Variable2 % array5(lower(1):upper(1),
831     &                          lower(2):upper(2),
832     &                          lower(3):upper(3),
833     &                          lower(4):upper(4),
834     &                          lower(5):upper(5))
835     &                        = Value
836C     
837              End Where
838      CASE (6)
839             Where (Variable1 % array6(
840     &           bound1(lower(1),1,2):bound1(upper(1),1,2),
841     &           bound1(lower(2),2,2):bound1(upper(2),2,2),
842     &           bound1(lower(2),3,2):bound1(upper(3),3,2),
843     &           bound1(lower(4),4,2):bound1(upper(4),4,2),
844     &           bound1(lower(5),5,2):bound1(upper(5),5,2),
845     &           bound1(lower(6),6,2):bound1(upper(6),6,2)) 
846     &            == Value)
847             Variable2 % array6(lower(1):upper(1),
848     &                          lower(2):upper(2),
849     &                          lower(3):upper(3),
850     &                          lower(4):upper(4),
851     &                          lower(5):upper(5),
852     &                          lower(6):upper(6))
853     &                        = Value
854C     
855              End Where
856      END SELECT
857C
858      return
859C
860      End Subroutine GiveAgrif_SpecialValueToTab_mpi   
861#else
862C     **************************************************************************
863CCC   Subroutine GiveAgrif_SpecialValueToTab
864C     **************************************************************************
865C
866      Subroutine GiveAgrif_SpecialValueToTab(Variable1,Variable2,
867     &                  lower,upper,Value,nbdim)
868C
869CCC   Description:
870CCC   
871C
872C     Declarations:
873C     
874     
875C
876C     Arguments     
877C
878      TYPE(AGRIF_VARIABLE), Pointer    :: Variable1
879      TYPE(AGRIF_VARIABLE), Pointer    :: Variable2
880      INTEGER                  :: nbdim
881      INTEGER,DIMENSION(nbdim) :: lower,upper
882      REAL                     :: Value
883C
884C     Local variables       
885C
886      SELECT CASE (nbdim)
887      CASE (1)
888             Where (Variable1 % array1(
889     &           lower(1):upper(1))
890     &            == Value)
891             Variable2 % array1(lower(1):upper(1))
892     &                        = Value
893C     
894              End Where
895      CASE (2)
896             Where (Variable1 % array2(
897     &           lower(1):upper(1),
898     &           lower(2):upper(2)) 
899     &            == Value)
900             Variable2 % array2(lower(1):upper(1),
901     &                          lower(2):upper(2))
902     &                        = Value
903C     
904              End Where
905      CASE (3)
906             Where (Variable1 % array3(
907     &           lower(1):upper(1),
908     &           lower(2):upper(2), 
909     &           lower(3):upper(3)) 
910     &            == Value)
911             Variable2 % array3(lower(1):upper(1),
912     &                          lower(2):upper(2),
913     &                          lower(3):upper(3))
914     &                         = Value
915C     
916              End Where
917      CASE (4)
918             Where (Variable1 % array4(
919     &           lower(1):upper(1),
920     &           lower(2):upper(2), 
921     &           lower(3):upper(3),
922     &           lower(4):upper(4)) 
923     &            == Value)
924             Variable2 % array4(lower(1):upper(1),
925     &                          lower(2):upper(2),
926     &                          lower(3):upper(3),
927     &                          lower(4):upper(4))
928     &                        = Value
929C     
930              End Where
931      CASE (5)
932             Where (Variable1 % array5(
933     &           lower(1):upper(1),
934     &           lower(2):upper(2),
935     &           lower(3):upper(3),
936     &           lower(4):upper(4),
937     &           lower(5):upper(5)) 
938     &            == Value)
939             Variable2 % array5(lower(1):upper(1),
940     &                          lower(2):upper(2),
941     &                          lower(3):upper(3),
942     &                          lower(4):upper(4),
943     &                          lower(5):upper(5))
944     &                        = Value
945C     
946              End Where
947      CASE (6)
948             Where (Variable1 % array6(
949     &           lower(1):upper(1),
950     &           lower(2):upper(2),
951     &           lower(2):upper(3),
952     &           lower(4):upper(4),
953     &           lower(5):upper(5),
954     &           lower(6):upper(6)) 
955     &            == Value)
956             Variable2 % array6(lower(1):upper(1),
957     &                          lower(2):upper(2),
958     &                          lower(3):upper(3),
959     &                          lower(4):upper(4),
960     &                          lower(5):upper(5),
961     &                          lower(6):upper(6))
962     &                        = Value
963C     
964              End Where
965      END SELECT
966C
967      return
968C
969      End Subroutine GiveAgrif_SpecialValueToTab   
970#endif
971C
972C
973#ifdef AGRIF_MPI
974C     **************************************************************************
975CCC   Subroutine Where_ValTabToTab_mpi
976C     **************************************************************************
977C
978      Subroutine Where_ValTabToTab_mpi(
979     &                  Variable1,Variable2,
980     &                  lower,upper,Value,nbdim)
981C
982CCC   Description:
983CCC   
984C
985C     Declarations:
986C     
987     
988C
989C     Arguments     
990C
991      TYPE(AGRIF_VARIABLE), Pointer     :: Variable1
992      TYPE(AGRIF_VARIABLE), Pointer     :: Variable2
993      INTEGER                  :: nbdim
994      INTEGER,DIMENSION(nbdim) :: lower,upper
995      REAL                     :: Value
996      INTEGER :: i,j,k,l,m,n
997C
998C     Local variables       
999C
1000      SELECT CASE (nbdim)
1001      CASE (1)
1002            DO i = lower(1),upper(1)
1003              IF (variable1%array1(i) == Value) then
1004                variable1%array1(i)=Variable2%array1(i)
1005              ENDIF
1006            ENDDO
1007      CASE (2)
1008            DO j = lower(2),upper(2)
1009            DO i = lower(1),upper(1)
1010              IF (variable1%array2(i,j) == Value) then
1011                variable1%array2(i,j)=Variable2%array2(i,j)
1012              ENDIF
1013            ENDDO
1014            ENDDO
1015      CASE (3)
1016            DO k = lower(3),upper(3)
1017            DO j = lower(2),upper(2)
1018            DO i = lower(1),upper(1)
1019              IF (variable1%array3(i,j,k) == Value) then
1020                variable1%array3(i,j,k)=Variable2%array3(i,j,k)
1021              ENDIF
1022            ENDDO
1023            ENDDO
1024            ENDDO
1025      CASE (4)
1026            DO l = lower(4),upper(4)
1027            DO k = lower(3),upper(3)
1028            DO j = lower(2),upper(2)
1029            DO i = lower(1),upper(1)
1030              IF (variable1%array4(i,j,k,l) == Value) then
1031                variable1%array4(i,j,k,l)=Variable2%array4(i,j,k,l)
1032              ENDIF
1033            ENDDO
1034            ENDDO
1035            ENDDO
1036            ENDDO
1037      CASE (5)
1038            DO m = lower(5),upper(5)
1039            DO l = lower(4),upper(4)
1040            DO k = lower(3),upper(3)
1041            DO j = lower(2),upper(2)
1042            DO i = lower(1),upper(1)
1043              IF (variable1%array5(i,j,k,l,m) == Value) then
1044              variable1%array5(i,j,k,l,m)=Variable2%array5(i,j,k,l,m)
1045              ENDIF
1046            ENDDO
1047            ENDDO
1048            ENDDO
1049            ENDDO
1050            ENDDO
1051      CASE (6)
1052            DO n = lower(6),upper(6)
1053            DO m = lower(5),upper(5)
1054            DO l = lower(4),upper(4)
1055            DO k = lower(3),upper(3)
1056            DO j = lower(2),upper(2)
1057            DO i = lower(1),upper(1)
1058              IF (variable1%array6(i,j,k,l,m,n) == Value) then
1059            variable1%array6(i,j,k,l,m,n)=Variable2%array6(i,j,k,l,m,n)
1060              ENDIF
1061            ENDDO
1062            ENDDO
1063            ENDDO
1064            ENDDO
1065            ENDDO
1066            ENDDO
1067      END SELECT
1068C
1069      return
1070C
1071      End Subroutine Where_ValTabToTab_mpi   
1072#endif
1073
1074C     **************************************************************************
1075CCC   Subroutine PreProcessToInterpOrUpdate
1076C     **************************************************************************
1077C
1078      Subroutine PreProcessToInterpOrUpdate(parent,child,
1079     &             petab_Child,
1080     &             pttab_Child,pttab_Parent,
1081     &             s_Child,s_Parent,
1082     &             ds_Child,ds_Parent,
1083     &             nbdim)
1084C
1085CCC   Description:
1086CCC   
1087C
1088C     Declarations:
1089C     
1090C     arguments                                   
1091      TYPE(AGRIF_PVariable) :: parent   ! Variable on the parent grid
1092      TYPE(AGRIF_PVariable) :: child    ! Variable on the child grid
1093      INTEGER :: nbdim                 
1094      INTEGER,DIMENSION(6) :: pttab_child 
1095      INTEGER,DIMENSION(6) :: petab_child     
1096      INTEGER,DIMENSION(6) :: pttab_parent 
1097      TYPE(AGRIF_Variable), Pointer :: root ! Pointer on the variable of the
1098                                            ! root grid
1099      TYPE(Agrif_Grid), Pointer :: Agrif_Child_Gr,Agrif_Parent_Gr
1100      REAL, DIMENSION(6) :: s_child,s_parent
1101      REAL, DIMENSION(6) :: ds_child,ds_parent
1102C     locals variables
1103      INTEGER :: n
1104     
1105C
1106C     Arguments     
1107C
1108
1109C
1110C     Local variables       
1111C
1112      Agrif_Child_Gr => Agrif_Curgrid
1113      Agrif_Parent_Gr => Agrif_Curgrid % parent
1114C
1115      root => child % var % root_var 
1116C
1117C     Number of dimensions of the current grid
1118      nbdim = root % nbdim
1119C     
1120      do n=1,nbdim
1121C           
1122        Select case(root % interptab(n))
1123C
1124C       Value of interptab(n) can be either x,y,z or N for a no space 
1125C       DIMENSION           
1126C
1127C         The DIMENSION is 'x'
1128          case('x')
1129C
1130            pttab_Child(n) = root % point(1)
1131C           
1132            pttab_Parent(n) = root % point(1)
1133C       
1134            s_Child(n) = Agrif_Child_Gr % Agrif_x(1)
1135C
1136            s_Parent(n) = Agrif_Parent_Gr % Agrif_x(1)
1137C       
1138            ds_Child(n) = Agrif_Child_Gr % Agrif_d(1)
1139C
1140            ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(1)
1141C                     
1142            if (root % posvar(n).EQ.1) then
1143C         
1144              petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(1)
1145C       
1146              else
1147C         
1148                petab_Child(n) = pttab_Child(n) + 
1149     &                              Agrif_Child_Gr%nb(1) - 1
1150C         
1151                s_Child(n) = s_Child(n) + ds_Child(n)/2.
1152C
1153                s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
1154C       
1155            endif                 
1156C
1157C         The DIMENSION is 'y'
1158          case('y')
1159C
1160            pttab_Child(n) = root % point(2)
1161C           
1162            pttab_Parent(n) = root % point(2)
1163C       
1164            s_Child(n) = Agrif_Child_Gr % Agrif_x(2)
1165C
1166            s_Parent(n) = Agrif_Parent_Gr % Agrif_x(2) 
1167C       
1168            ds_Child(n) = Agrif_Child_Gr % Agrif_d(2)
1169C
1170            ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(2)
1171C                     
1172            if (root % posvar(n).EQ.1) then
1173C         
1174             petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(2)
1175C         
1176              else
1177C         
1178                petab_Child(n) = pttab_Child(n) + 
1179     &                       Agrif_Child_Gr%nb(2) - 1
1180C         
1181                s_Child(n) = s_Child(n) + ds_Child(n)/2.
1182C
1183                s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
1184C       
1185            endif
1186           
1187C
1188C         The DIMENSION is 'z'                           
1189          case('z')
1190C
1191            pttab_Child(n) = root % point(3)
1192C           
1193            pttab_Parent(n) = root % point(3)
1194C       
1195            s_Child(n) = Agrif_Child_Gr % Agrif_x(3)
1196C
1197            s_Parent(n) = Agrif_Parent_Gr % Agrif_x(3)
1198C       
1199            ds_Child(n) = Agrif_Child_Gr % Agrif_d(3)
1200C
1201            ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(3)
1202C                     
1203            if (root % posvar(n).EQ.1) then
1204C         
1205             petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(3)
1206C         
1207              else
1208C         
1209                petab_Child(n) = pttab_Child(n) + 
1210     &                      Agrif_Child_Gr%nb(3) - 1
1211C
1212                s_Child(n) = s_Child(n) + ds_Child(n)/2.
1213C
1214                s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
1215C       
1216            endif       
1217C 
1218C         The DIMENSION is not space                           
1219          case('N')
1220C
1221C         The next coefficients are calculated in order to do a simple copy of 
1222C         values of the grid variable when the procedure of interpolation is 
1223C         called for this DIMENSION
1224C     
1225            Call Agrif_nbdim_Get_bound(child % var,
1226     &                           pttab_Child(n),petab_Child(n),n,nbdim)
1227C
1228C           No interpolation but only a copy of the values of the grid variable
1229C
1230            pttab_Parent(n) = pttab_Child(n)
1231C             
1232            s_Child(n)=0.
1233C     
1234            s_Parent(n)=0. 
1235C     
1236            ds_Child(n)=1.
1237C     
1238            ds_Parent(n)=1.
1239C
1240        End select
1241C           
1242      enddo     
1243C
1244      return
1245C
1246      End Subroutine PreProcessToInterpOrUpdate     
1247
1248#ifdef AGRIF_MPI
1249C
1250C     **************************************************************************
1251CCC   Subroutine GetLocalBoundaries
1252C     **************************************************************************
1253C
1254      Subroutine GetLocalBoundaries(tab1,tab2,i,lb,ub,deb,fin)
1255C
1256CCC   Descritpion:
1257C 
1258C
1259C     Declarations:
1260C
1261
1262C
1263C
1264C     Scalar arguments
1265      INTEGER  ::  tab1,tab2
1266      INTEGER  ::  i
1267      INTEGER  ::  lb,ub
1268      INTEGER  ::  deb,fin
1269C
1270C     Local scalars
1271      INTEGER  ::  imin,imax
1272      INTEGER  ::  i1,i2
1273C
1274C
1275      Call AGRIF_InvLoc(lb,AGRIF_ProcRank,i,imin)
1276C
1277      Call AGRIF_InvLoc(ub,AGRIF_ProcRank,i,imax)
1278C
1279C
1280      if (imin > tab2) then
1281C
1282          i1 = imax - imin
1283C
1284        else
1285C
1286          i1 = max(tab1 - imin,0)
1287C
1288      endif
1289C
1290      if (imax < tab1) then
1291C
1292          i2 = -(imax - imin)
1293C
1294        else
1295C
1296          i2 = min(tab2 - imax,0)
1297C
1298      endif
1299C
1300      deb = lb + i1
1301C
1302      fin = ub + i2
1303C
1304C
1305      End Subroutine GetLocalBoundaries
1306C
1307#endif
1308C
1309C
1310#ifdef AGRIF_MPI
1311C
1312C     **************************************************************************
1313CCC   Subroutine Agrif_GlobtoLocInd
1314C     **************************************************************************
1315C
1316      Subroutine Agrif_GlobtoLocInd(tabarray,lboundl,uboundl,tab1,tab2,
1317     &                              nbdim,rank)
1318C
1319CCC   Description:
1320CCC   For a global index located on the current processor, tabarray gives the 
1321CCC   corresponding local index   
1322C
1323C
1324C     Declarations:
1325C
1326
1327C
1328C     Arguments
1329      INTEGER :: nbdim
1330      INTEGER,DIMENSION(nbdim) :: tab1,tab2
1331      INTEGER,DIMENSION(minval(tab1):maxval(tab2),nbdim,2 ) :: tabarray
1332      INTEGER,DIMENSION(nbdim) :: lboundl,uboundl
1333      INTEGER :: rank
1334C
1335C     Local variables
1336      INTEGER :: i,i1,k
1337C
1338C
1339      tabarray(:,:,1) = 0
1340C       
1341      do i = 1,nbdim
1342C       
1343        Call Agrif_Invloc(lboundl(i),rank,i,i1)
1344       
1345        do k=tab1(i)+lboundl(i)-i1,tab2(i)+lboundl(i)-i1
1346           tabarray(k-lboundl(i)+i1,i,1)=1
1347           tabarray(k-lboundl(i)+i1,i,2)=k
1348        enddo
1349
1350C
1351      enddo
1352C
1353      Return
1354C
1355C
1356      End Subroutine Agrif_GlobtoLocInd
1357
1358C
1359C     **************************************************************************
1360CCC   Subroutine Agrif_GlobtoLocInd2
1361C     **************************************************************************
1362C
1363      Subroutine Agrif_GlobtoLocInd2(tabarray,lboundl,uboundl,tab1,tab2,
1364     &                              nbdim,rank,member)
1365C
1366CCC   Description:
1367CCC   For a global index located on the current processor, tabarray gives the 
1368CCC   corresponding local index   
1369C
1370C
1371C     Declarations:
1372C
1373
1374C
1375C     Arguments
1376      INTEGER :: nbdim
1377      INTEGER,DIMENSION(nbdim) :: tab1,tab2
1378      INTEGER,DIMENSION(nbdim,2,2 ) :: tabarray
1379      INTEGER,DIMENSION(nbdim) :: lboundl,uboundl
1380      INTEGER :: rank
1381      LOGICAL :: member
1382C   
1383C     Local variables
1384      INTEGER :: i,i1,k
1385      INTEGER :: nbloc(nbdim)
1386C
1387C
1388      tabarray(:,1,:) =  HUGE(1)
1389      tabarray(:,2,:) =  -HUGE(1)
1390
1391      nbloc = 0
1392C       
1393      do i = 1,nbdim
1394C       
1395        Call Agrif_Invloc(lboundl(i),rank,i,i1)
1396       
1397        do k=tab1(i)+lboundl(i)-i1,tab2(i)+lboundl(i)-i1
1398          IF ((k .GE. lboundl(i)) .AND. (k.LE.uboundl(i))) THEN
1399            nbloc(i) = 1
1400            tabarray(i,1,1) = min(tabarray(i,1,1),k-lboundl(i)+i1)
1401            tabarray(i,2,1) = max(tabarray(i,2,1),k-lboundl(i)+i1)
1402       
1403            tabarray(i,1,2) = min(tabarray(i,1,2),k)
1404            tabarray(i,2,2) = max(tabarray(i,2,2),k)
1405          ENDIF
1406        enddo
1407C
1408      enddo
1409
1410      member = .FALSE.
1411      IF (sum(nbloc) == nbdim) member = .TRUE.
1412C
1413      Return
1414C
1415C
1416      End Subroutine Agrif_GlobtoLocInd2
1417C
1418#endif     
1419
1420      End Module Agrif_Arrays
Note: See TracBrowser for help on using the repository browser.