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.
modflux.F in branches/UKMO/dev_r5518_CICE_coupling_GSI7/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES – NEMO

source: branches/UKMO/dev_r5518_CICE_coupling_GSI7/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modflux.F @ 5618

Last change on this file since 5618 was 5618, checked in by dancopsey, 9 years ago

Stripped out SVN keywords.

File size: 11.6 KB
Line 
1C     Agrif (Adaptive Grid Refinement In Fortran)
2C
3C     Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
4C                        Christophe Vouland (Christophe.Vouland@imag.fr)   
5C
6C     This program is free software; you can redistribute it and/or modify
7C     it under the terms of the GNU General Public License as published by
8C     the Free Software Foundation; either version 2 of the License, or
9C     (at your option) any later version.
10C
11C     This program is distributed in the hope that it will be useful,
12C     but WITHOUT ANY WARRANTY; without even the implied warranty of
13C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14C     GNU General Public License for more details.
15C
16C     You should have received a copy of the GNU General Public License
17C     along with this program; if not, write to the Free Software
18C     Foundation, Inc., 59 Temple Place-Suite 330, Boston, MA 02111-1307, USA.
19C
20C
21C
22CCC   Module Agrif_fluxmod
23C
24      Module Agrif_fluxmod
25      Use Agrif_types
26      Use Agrif_Arrays
27      Use Agrif_Curgridfunctions
28     
29      CONTAINS 
30     
31     
32      Subroutine Agrif_AllocateFlux(Flux,fluxtab)
33      Type(Agrif_Flux), Pointer :: Flux
34      Real, Dimension(:,:) :: fluxtab
35      Type(Agrif_Profile), Pointer :: Profile
36      Integer :: dimensio,n,n2
37      INTEGER, DIMENSION(:,:), Pointer :: normalsizes
38      INTEGER, DIMENSION(6) :: unitarray
39      Type(Agrif_Variable), Pointer :: fluxtabvar
40      Integer :: nbout
41     
42      Profile => Flux%profile
43      dimensio = Profile%nbdim
44     
45      unitarray = 1
46     
47      do n=1,dimensio
48        IF (Profile%posvar(n) == 1) THEN
49          IF (Profile%interptab(n) == 'x') THEN
50            Allocate(Flux%fluxtabx)
51            fluxtabvar => Flux%fluxtabx
52          ELSE IF (Profile%interptab(n) == 'y') THEN
53            Allocate(Flux%fluxtaby)
54            fluxtabvar => Flux%fluxtaby
55          ELSE IF (Profile%interptab(n) == 'z') THEN
56            Allocate(Flux%fluxtabz)
57            fluxtabvar => Flux%fluxtabz
58          ENDIF
59          ALLOCATE(fluxtabvar%iarray2(2,6))
60          normalsizes=>fluxtabvar%iarray2
61          normalsizes(1,1) = 2
62          nbout = 1
63          DO n2 = 1,dimensio
64            IF (n2 .NE. n) THEN
65              nbout = nbout + 1
66              If ((Profile%posvar(n2) == 1)
67     &            .OR.(Profile%posvar(n2) == 2)) THEN
68                IF (Profile%interptab(n2) == 'x') THEN
69                  normalsizes(2,n2) = 
70     &                Agrif_Curgrid%nb(1)/agrif_Curgrid%spaceref(1)
71                  normalsizes(1,nbout) = 
72     &                Agrif_Curgrid%nb(1)/agrif_Curgrid%spaceref(1)
73                ELSE IF (Profile%interptab(n2) == 'y') THEN
74                  normalsizes(2,n2) = 
75     &                Agrif_Curgrid%nb(2)/agrif_Curgrid%spaceref(2)
76                  normalsizes(1,nbout) = 
77     &                Agrif_Curgrid%nb(2)/agrif_Curgrid%spaceref(2)
78                ELSE IF (Profile%interptab(n2) == 'z') THEN
79                  normalsizes(2,n2) = 
80     &                Agrif_Curgrid%nb(3)/agrif_Curgrid%spaceref(3)
81                  normalsizes(1,nbout) = 
82     &                Agrif_Curgrid%nb(3)/agrif_Curgrid%spaceref(3)
83                ENDIF
84              ELSE
85                normalsizes(2,n2) = SIZE(fluxtab,n2)
86                normalsizes(1,nbout) = SIZE(fluxtab,n2)
87              ENDIF
88            ENDIF
89          ENDDO         
90        ENDIF
91      enddo
92     
93     
94      do n=1,dimensio
95        IF (Profile%posvar(n) == 1) THEN
96          IF (Profile%interptab(n) == 'x') THEN
97            fluxtabvar => Flux%fluxtabx
98          ELSE IF (Profile%interptab(n) == 'y') THEN
99            fluxtabvar => Flux%fluxtaby
100          ELSE IF (Profile%interptab(n) == 'z') THEN
101            fluxtabvar => Flux%fluxtabz
102          ENDIF
103          Call Agrif_nbdim_allocation(fluxtabvar,unitarray(1:dimensio),
104     &          fluxtabvar%iarray2(1,1:dimensio),dimensio)
105        ENDIF
106      enddo
107     
108      Flux%fluxallocated = .TRUE.
109     
110      End Subroutine Agrif_AllocateFlux
111     
112      FUNCTION Agrif_Search_Flux(fluxname)
113      character*(*) fluxname
114      Type(Agrif_Flux), Pointer :: Agrif_Search_Flux
115     
116      Type(Agrif_Flux), pointer :: parcours
117      Logical :: foundflux
118     
119      foundflux = .FALSE.
120      parcours => Agrif_Curgrid%fluxes
121     
122      Do While (Associated(parcours))
123         IF (parcours % fluxname == fluxname) THEN
124           foundflux = .TRUE.
125           EXIT
126         ENDIF
127         parcours => parcours%nextflux
128      End Do
129     
130      IF (.NOT.foundflux) THEN
131      write(*,*) 'The array flux '''
132     &           //TRIM(fluxname)//''' has not been declared'
133      stop
134      ENDIF     
135     
136      Agrif_Search_Flux => parcours
137     
138      End Function Agrif_Search_Flux
139     
140      Subroutine Agrif_Save_Fluxtab(Flux,Fluxtab)
141      Type(Agrif_Flux), Pointer :: Flux
142      Real, Dimension(:,:) :: Fluxtab
143      INTEGER, DIMENSION(:,:), Pointer :: normalsizes
144      INTEGER, DIMENSION(6) :: normalsizes2, normalsizes3
145      INTEGER, DIMENSION(6) :: unitarray2, unitarray3
146      Type(Agrif_Variable), Pointer :: fluxtabvar
147      Type(Agrif_Profile), Pointer :: Profile
148      Integer :: dimensio,n,n2,j,j1,j2
149     
150      Profile => Flux%profile
151      dimensio = Profile%nbdim
152           
153      do n=1,dimensio
154        IF (Profile%posvar(n) == 1) THEN
155          IF (Profile%interptab(n) == 'x') THEN
156            fluxtabvar => Flux%fluxtabx
157          ELSE IF (Profile%interptab(n) == 'y') THEN
158            fluxtabvar => Flux%fluxtaby
159          ELSE IF (Profile%interptab(n) == 'z') THEN
160            fluxtabvar => Flux%fluxtabz
161          ENDIF
162          normalsizes => fluxtabvar%iarray2
163          unitarray2 = 1
164          unitarray3 = 1
165          normalsizes2 = normalsizes(1,:)
166          normalsizes3 = normalsizes(2,:)
167         
168          unitarray3(n) = Profile%point(n)
169          normalsizes3(n) = Profile%point(n) 
170                             
171          SELECT CASE(dimensio)
172          CASE(1)
173          CASE(2)
174            j1 = unitarray3(2)
175            Do j=unitarray3(2),normalsizes3(2)
176            do j2 = j1,j1+Agrif_curgrid%spaceref(2)
177!            print *,'flux stocke fiun = ',j2,fluxtab(unitarray3(1),j2)
178            enddo
179            fluxtabvar%array2(1:1,j) = 
180     &      fluxtabvar%array2(1:1,j) +
181     &             SUM(fluxtab(unitarray3(1):normalsizes3(1),
182     &                        j1:j1+Agrif_Curgrid%spaceref(2)))
183             j1 = j1+Agrif_Curgrid%spaceref(2)
184            EndDo
185          END SELECT
186         
187          unitarray3(n) = Profile%point(n)+Agrif_Curgrid%nb(n)
188          normalsizes3(n) = Profile%point(n)+Agrif_Curgrid%nb(n) 
189          SELECT CASE(dimensio)
190          CASE(1)
191          CASE(2)
192            j1 = unitarray3(2)
193            Do j=unitarray3(2),normalsizes3(2)
194            fluxtabvar%array2(2:2,j) = 
195     &      fluxtabvar%array2(2:2,j) +
196     &             SUM(fluxtab(unitarray3(1):normalsizes3(1),
197     &                        j1:j1+Agrif_Curgrid%spaceref(2)))
198             j1 = j1+Agrif_Curgrid%spaceref(2)
199            EndDo
200         END SELECT
201        ENDIF
202      enddo
203                 
204      End Subroutine Agrif_Save_Fluxtab
205
206      Subroutine Agrif_Save_Fluxtab_child(Flux,Fluxtab)
207      Type(Agrif_Flux), Pointer :: Flux
208      Real, Dimension(:,:) :: Fluxtab
209      INTEGER, DIMENSION(:,:), Pointer :: normalsizes
210      INTEGER, DIMENSION(6) :: normalsizes2, normalsizes3
211      INTEGER, DIMENSION(6) :: unitarray2, unitarray3
212      Type(Agrif_Variable), Pointer :: fluxtabvar
213      Type(Agrif_Profile), Pointer :: Profile
214      Integer :: dimensio,n,n2
215     
216      Profile => Flux%profile
217      dimensio = Profile%nbdim
218           
219      do n=1,dimensio
220        IF (Profile%posvar(n) == 1) THEN
221          IF (Profile%interptab(n) == 'x') THEN
222            fluxtabvar => Flux%fluxtabx
223          ELSE IF (Profile%interptab(n) == 'y') THEN
224            fluxtabvar => Flux%fluxtaby
225          ELSE IF (Profile%interptab(n) == 'z') THEN
226            fluxtabvar => Flux%fluxtabz
227          ENDIF
228          normalsizes => fluxtabvar%iarray2
229          unitarray2 = 1
230          unitarray3 = 1
231          normalsizes2 = normalsizes(1,:)
232          normalsizes3 = normalsizes(2,:)
233         
234          unitarray3(n) = Profile%point(n)+Agrif_Curgrid%ix(n)
235          normalsizes3(n) = unitarray3(n)
236                             
237          SELECT CASE(dimensio)
238          CASE(1)
239          CASE(2)
240            fluxtabvar%array2(1:1,
241     &                        unitarray2(2):normalsizes2(2)) = 
242     &      - fluxtab(unitarray3(1):normalsizes3(1),
243     &                        unitarray3(2):normalsizes3(2))
244!        print *,'flux stocke = ',fluxtab(unitarray3(1):normalsizes3(1),
245!     &                        unitarray3(2):normalsizes3(2))
246          END SELECT
247         
248          unitarray3(n) = unitarray3(n)+
249     &         Agrif_Curgrid%nb(n)/Agrif_Curgrid%spaceref(n)
250          normalsizes3(n) = unitarray3(n)
251          SELECT CASE(dimensio)
252          CASE(1)
253          CASE(2)
254            fluxtabvar%array2(2:2,
255     &                        unitarray2(2):normalsizes2(2)) = 
256     &      - fluxtab(unitarray3(1):normalsizes3(1),
257     &                        unitarray3(2):normalsizes3(2))   
258         END SELECT
259        ENDIF
260      enddo
261                 
262      End Subroutine Agrif_Save_Fluxtab_child
263     
264      Subroutine Agrif_Cancel_Fluxarray(Flux)
265      Type(Agrif_Flux), Pointer :: Flux
266      Type(Agrif_Variable), Pointer :: fluxtabvar
267      Type(Agrif_Profile), Pointer :: Profile
268      Integer :: dimensio,n,n2
269     
270      Profile => Flux%profile
271      dimensio = Profile%nbdim
272           
273      do n=1,dimensio
274        IF (Profile%posvar(n) == 1) THEN
275          IF (Profile%interptab(n) == 'x') THEN
276            fluxtabvar => Flux%fluxtabx
277          ELSE IF (Profile%interptab(n) == 'y') THEN
278            fluxtabvar => Flux%fluxtaby
279          ELSE IF (Profile%interptab(n) == 'z') THEN
280            fluxtabvar => Flux%fluxtabz
281          ENDIF
282                             
283          SELECT CASE(dimensio)
284          CASE(1)
285          CASE(2)
286            fluxtabvar%array2 = 0.
287          END SELECT
288        ENDIF
289      enddo
290                 
291      End Subroutine Agrif_Cancel_Fluxarray 
292     
293      Subroutine Agrif_FluxCorrect(Flux, procname)
294      Type(Agrif_Flux), Pointer :: Flux
295      External :: procname
296      Type(Agrif_Variable), Pointer :: fluxtabvar
297      Type(Agrif_Profile), Pointer :: Profile
298      Integer :: dimensio,n,n2,j1,j2
299      Integer, Dimension(:), Allocatable :: Loctab
300      Integer :: locind
301     
302      Profile => Flux%profile
303      dimensio = Profile%nbdim
304
305      do n=1,dimensio
306        IF (Profile%posvar(n) == 1) THEN
307          IF (Profile%interptab(n) == 'x') THEN
308            fluxtabvar => Flux%fluxtabx
309            locind = 1
310          ELSE IF (Profile%interptab(n) == 'y') THEN
311            fluxtabvar => Flux%fluxtaby
312            locind = 2
313          ELSE IF (Profile%interptab(n) == 'z') THEN
314            fluxtabvar => Flux%fluxtabz
315            locind = 3
316          ENDIF
317                             
318          SELECT CASE(dimensio)
319          CASE(1)
320          CASE(2)
321           Allocate(Loctab(2))
322           Loctab(1) = Agrif_Curgrid%ix(locind)
323           Loctab(2) = Agrif_Curgrid%ix(locind)+
324     &         Agrif_Curgrid%nb(locind)/Agrif_Curgrid%spaceref(locind)
325           j1 = agrif_curgrid%ix(2)
326           j2 = agrif_curgrid%ix(2)+
327     &        agrif_curgrid%nb(2)/Agrif_curgrid%spaceref(2)
328           Call Agrif_ChildGrid_to_ParentGrid()
329            Call procname(fluxtabvar%array2,Loctab(1),Loctab(2),j1,j2)
330           Call Agrif_ParentGrid_to_ChildGrid()
331          END SELECT
332        ENDIF
333      enddo
334     
335      If (Allocated(Loctab)) Deallocate(Loctab)
336                 
337      End Subroutine Agrif_FluxCorrect 
338         
339      End Module Agrif_fluxmod
Note: See TracBrowser for help on using the repository browser.