source: trunk/AGRIF/AGRIF_FILES/modupdatebasic.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: 6.6 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_Updatebasic
26C     
27C
28      Module Agrif_Updatebasic
29C
30CCC   Description:
31CCC   Module containing different procedures of update (copy,average,
32CCC   full_weighting) used in the Agrif_Update module.
33C
34C     Modules used:
35C
36      USE Agrif_types
37     
38      IMPLICIT NONE
39C             
40
41      CONTAINS
42C     Define procedures contained in this module
43C
44C
45C
46C     ************************************************************************** 
47CCC   Subroutine Copy1d 
48C     ************************************************************************** 
49C
50      Subroutine copy1d(x,y,np,nc,
51     &                  s_parent,s_child,ds_parent,ds_child) 
52C
53CCC   Description:
54CCC   Subroutine to do a copy on a parent grid (vector x) from its child grid 
55CCC   (vector y). 
56C
57CC    Method:
58C
59C     Declarations:
60C
61     
62C       
63C     Arguments
64      INTEGER             :: np,nc     
65      REAL, DIMENSION(np) :: x     
66      REAL, DIMENSION(nc) :: y 
67      REAL                :: s_parent,s_child
68      REAL                :: ds_parent,ds_child
69C
70C     Local variables
71      INTEGER :: i,locind_child_left,coeffraf
72C 
73C
74      coeffraf = nint(ds_parent/ds_child)
75C
76      if (coeffraf == 1) then
77C
78          locind_child_left = 1 + nint((s_parent - s_child)/ds_child)
79C       
80          x(1:np) = y(locind_child_left:locind_child_left+np-1)
81C
82          return
83C
84      endif
85C
86     
87      locind_child_left = 1 + nint((s_parent - s_child)/ds_child)
88     
89      do i = 1,np
90C     
91         x(i) = y(locind_child_left)
92C
93         locind_child_left = locind_child_left + coeffraf
94C         
95      enddo   
96       
97C
98      Return
99C
100C
101      End Subroutine copy1d
102C
103C
104C
105C     ************************************************************************** 
106CCC   Subroutine Average1d 
107C     ************************************************************************** 
108C   
109      Subroutine average1d(x,y,np,nc,
110     &                     s_parent,s_child,ds_parent,ds_child) 
111C
112CCC   Description:
113CCC   Subroutine to do an update by average on a parent grid (vector x)from its 
114CCC   child grid (vector y).
115C
116C     Arguments
117      INTEGER             :: np,nc     
118      REAL, DIMENSION(np) :: x     
119      REAL, DIMENSION(nc) :: y 
120      REAL                :: s_parent,s_child
121      REAL                :: ds_parent,ds_child
122C
123C     Local variables
124      INTEGER :: i,locind_child_left,coeffraf,ii
125      REAL    :: xpos 
126      INTEGER :: nbnonnuls
127      INTEGER :: diffmod
128C 
129C
130      coeffraf = nint(ds_parent/ds_child)
131C
132      if (coeffraf == 1) then
133C
134          locind_child_left = 1 + nint((s_parent - s_child)/ds_child)
135C       
136          x(1:np) = y(locind_child_left:locind_child_left+np-1)
137C
138          return
139C
140      endif
141C
142      xpos = s_parent     
143     
144      x = 0.
145C
146      diffmod = 0
147     
148      IF ( mod(coeffraf,2) == 0 ) diffmod = 1
149     
150      do i = 1,np
151C
152        locind_child_left = 1 + agrif_int((xpos - s_child)/ds_child)
153C
154        if ((locind_child_left-1 < 1) 
155     &      .OR. (locind_child_left+1 > nc)) then
156C
157            x(i) = y(locind_child_left)               
158C
159          else
160          nbnonnuls = 0
161          Do ii = -coeffraf/2+locind_child_left+diffmod,
162     &                coeffraf/2+locind_child_left
163C 
164            IF (Agrif_UseSpecialValueInUpdate) THEN
165            IF (y(ii) .NE. Agrif_SpecialValueFineGrid) THEN
166               nbnonnuls = nbnonnuls + 1
167               x(i) = x(i) + y(ii)
168            ENDIF
169            ELSE
170               x(i) = x(i) + y(ii)
171            ENDIF
172          End Do
173            IF (Agrif_UseSpecialValueInUpdate) THEN
174                 IF (nbnonnuls .NE. 0) THEN
175                    x(i) = x(i)/nbnonnuls
176                 ELSE
177                    x(i) = Agrif_SpecialValueFineGrid
178                 ENDIF
179            ELSE
180                 x(i) = x(i)/coeffraf
181            ENDIF
182C
183        endif
184C
185        xpos = xpos + ds_parent
186C
187      enddo
188C
189      Return
190C           
191C     
192      End Subroutine average1d
193C
194C
195C
196C     ************************************************************************** 
197CCC   Subroutine Full_weighting1d 
198C     ************************************************************************** 
199C
200      Subroutine full_weighting1D(x,y,np,nc,
201     &                            s_parent,s_child,ds_parent,ds_child) 
202C
203CCC   Description:
204CCC   Subroutine to do an update by full_weighting on a parent grid (vector x) 
205CCC   from its child grid (vector y).
206C 
207C     Arguments
208      INTEGER             :: np,nc     
209      REAL, DIMENSION(np) :: x     
210      REAL, DIMENSION(nc) :: y 
211      REAL                :: s_parent,s_child
212      REAL                :: ds_parent,ds_child
213C
214C     Local variables
215      INTEGER :: i,locind_child_left,coeffraf
216      REAL    :: xpos 
217C 
218C
219      coeffraf = nint(ds_parent/ds_child)
220C
221      if (coeffraf == 1) then
222C
223          locind_child_left = 1 + nint((s_parent - s_child)/ds_child)
224C       
225          x(1:np) = y(locind_child_left:locind_child_left+np-1)
226C
227          return
228C
229      endif
230C
231      IF (coeffraf .NE. 3) THEN
232        print *,'FULL WEIGHTING NOT READY FOR COEFFRAF = 3'
233   STOP
234      ENDIF
235      xpos = s_parent     
236C
237      do i = 1,np
238C
239        locind_child_left = 1 + nint((xpos - s_child)/ds_child)
240C
241        if ((locind_child_left-1 < 1) 
242     &      .OR. (locind_child_left+1 > nc)) then
243C      Agrif_UseSpecialValueInUpdate = .TRUE.
244            x(i) = y(locind_child_left)               
245C
246          else
247C       
248            x(i) = (y(locind_child_left-1)+2.*y(locind_child_left)+
249     &              y(locind_child_left+1))/4.               
250C
251        endif
252C
253        xpos = xpos + ds_parent
254C
255      enddo
256C
257      Return
258C           
259C
260      End Subroutine full_weighting1D     
261C
262C
263C
264      End module AGRIF_updatebasic
Note: See TracBrowser for help on using the repository browser.