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 branches/UKMO/dev_r5518_v3.6_asm_nemovar_community_ersem_hem08/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES – NEMO

source: branches/UKMO/dev_r5518_v3.6_asm_nemovar_community_ersem_hem08/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modarrays.F @ 9319

Last change on this file since 9319 was 7730, checked in by dford, 7 years ago

Clear svn keywords.

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