New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
modarrays.F in trunk/AGRIF/AGRIF_FILES – NEMO

source: trunk/AGRIF/AGRIF_FILES/modarrays.F @ 1200

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

Adapt Agrif to the new SBC and correct several bugs for agrif (restart writing and reading), see ticket #133
Note : this fix does not work yet on NEC computerq (sxf90/360)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.2 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      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.