source: XMLIO_SERVER/trunk/src/XMLIO/mod_grid.f90 @ 40

Last change on this file since 40 was 40, checked in by ymipsl, 15 years ago
  • Les attributs XML peuvent désormais être passer dynamiquement à travers l'interface du server IO.
  • ajout d'un attribut name_suffix pour les fichiers

YM
File size: 10.0 KB
Line 
1MODULE mod_grid
2  USE mod_xmlio_parameters
3  USE mod_sorted_list
4  USE mod_domain
5  USE mod_zoom
6
7  IMPLICIT NONE
8
9  TYPE, PUBLIC :: grid
10    CHARACTER(len=str_len)      :: id
11    LOGICAL                     :: has_id
12    CHARACTER(len=str_len)      :: name
13    LOGICAL                     :: has_name
14    CHARACTER(len=str_len)      :: description
15    LOGICAL                     :: has_description
16    TYPE(domain),POINTER        :: domain
17    TYPE(vector_domain),POINTER :: subdomain
18    TYPE(sorted_list),POINTER   :: rank_ids
19    INTEGER,POINTER             :: ranks(:)
20    INTEGER                     :: ni
21    INTEGER                     :: nj
22    LOGICAL                     :: has_dimension
23    TYPE(vector_zoom),POINTER   :: associated_zoom
24    TYPE(zoom),POINTER          :: global_zoom
25  END TYPE grid
26
27  INCLUDE 'vector_grid_def.inc'
28 
29  TYPE(vector_grid),POINTER,SAVE             :: grid_Ids
30  TYPE(sorted_list),POINTER,SAVE,PRIVATE     :: Ids 
31
32CONTAINS
33  INCLUDE 'vector_grid_contains.inc'
34
35  SUBROUTINE grid__swap_context(saved_grid_Ids,saved_Ids)
36  IMPLICIT NONE
37    TYPE(vector_grid),POINTER          :: saved_grid_Ids
38    TYPE(sorted_list),POINTER          :: saved_Ids 
39   
40    grid_ids=>saved_grid_ids
41    ids=>saved_ids
42  END SUBROUTINE grid__swap_context
43 
44 
45  SUBROUTINE grid__init
46  IMPLICIT NONE
47   
48    CALL vector_grid__new(grid_Ids)
49    CALL sorted_list__new(Ids)
50   
51  END SUBROUTINE grid__init
52 
53  SUBROUTINE grid__get(Id,Pt_grid)
54  USE string_function
55  IMPLICIT NONE
56    CHARACTER(LEN=*),INTENT(IN)     :: Id
57    TYPE(grid),POINTER              :: Pt_grid
58
59    INTEGER                         :: Pos
60    LOGICAL                         :: success
61   
62    CALL sorted_list__find(Ids,hash(Id),Pos,success)
63    IF (success) THEN
64      Pt_grid=>grid_ids%at(Pos)%Pt
65    ELSE
66      Pt_grid=>NULL()
67    ENDIF
68   
69  END SUBROUTINE grid__get
70 
71  SUBROUTINE grid__new(pt_grid,Id)
72  USE string_function
73  IMPLICIT NONE
74   TYPE(grid), POINTER           :: pt_grid
75   CHARACTER(LEN=*),OPTIONAL     :: Id
76   INTEGER                       :: Pos
77   
78   ALLOCATE(pt_grid%domain)
79   ALLOCATE(pt_grid%subdomain)
80   ALLOCATE(pt_grid%rank_ids)
81   ALLOCATE(pt_grid%associated_zoom)
82   
83   CALL domain__new(pt_grid%domain)
84   CALL vector_domain__new(pt_grid%subdomain)
85   CALL sorted_list__new(pt_grid%rank_ids)
86   CALL vector_zoom__new(pt_grid%associated_zoom)
87   
88   pt_grid%has_id          = .FALSE.
89   pt_grid%has_name        = .FALSE.
90   pt_grid%has_description = .FALSE.
91   pt_grid%has_dimension   = .FALSE.
92   
93   IF (PRESENT(Id)) THEN
94     Pt_grid%id=TRIM(ADJUSTL(Id))
95     Pt_grid%has_id=.TRUE.
96     CALL vector_grid__set_new(grid_Ids,Pt_grid,Pos)
97     CALL sorted_list__Add(Ids,hash(id),Pos)
98   ENDIF
99   
100   CALL grid__get_new_zoom(pt_grid,pt_grid%global_zoom,id)
101
102 END SUBROUTINE grid__new
103
104  SUBROUTINE grid__set(pt_grid, name, description)
105  IMPLICIT NONE
106    TYPE(grid), POINTER :: pt_grid
107    CHARACTER(len=*)  ,OPTIONAL :: name
108    CHARACTER(len=*)  ,OPTIONAL :: description
109
110    IF (PRESENT(name)) THEN
111        pt_grid%name=TRIM(ADJUSTL(name))
112        pt_grid%has_name = .TRUE.
113    ENDIF
114
115    IF (PRESENT(description)) THEN
116        pt_grid%description=TRIM(ADJUSTL(description))
117        pt_grid%has_description = .TRUE.
118    ENDIF
119
120  END SUBROUTINE grid__set
121
122
123  SUBROUTINE grid__set_attribut(id,attrib)
124  USE mod_attribut
125  USE mod_grid_attribut
126  USE error_msg
127  IMPLICIT NONE
128    CHARACTER(LEN=*),INTENT(IN) :: id
129    TYPE(attribut),INTENT(IN) :: attrib
130
131    TYPE(grid),POINTER              :: Pt_grid
132    INTEGER                         :: Pos
133    LOGICAL                         :: success
134   
135    CALL sorted_list__find(Ids,hash(Id),Pos,success)
136    IF (success) THEN
137      Pt_grid=>grid_ids%at(Pos)%Pt
138    ELSE
139      WRITE(message,*) 'grid id :',id,'is undefined'
140      CALL error('mod_grid::grid__set_attribut')
141    ENDIF 
142   
143    SELECT CASE(attrib%name)
144      CASE (grid__name)
145        IF (attrib%type==string0) CALL  grid__set(pt_grid,name=attrib%string0_ptr) ; RETURN
146      CASE (grid__description)
147        IF (attrib%type==string0) CALL  grid__set(pt_grid,description=attrib%string0_ptr) ; RETURN
148     END SELECT
149
150     WRITE(message,*) 'grid id ',id,' : Attribute type is incompatible with the provided value'
151     CALL error('mod_grid::grid__set_attribut')
152   
153  END SUBROUTINE grid__set_attribut
154 
155  SUBROUTINE grid__set_dimension(pt_grid, ni, nj)
156  IMPLICIT NONE
157    TYPE(grid), POINTER   :: pt_grid
158    INTEGER,INTENT(IN)    :: ni
159    INTEGER,INTENT(IN)    :: nj
160   
161    pt_grid%ni=ni
162    pt_grid%nj=nj
163    pt_grid%has_dimension=.TRUE.
164   
165  END SUBROUTINE grid__set_dimension
166   
167
168  SUBROUTINE grid__get_new_subdomain(Pt_grid,rank,pt_domain)
169  IMPLICIT NONE
170    TYPE(grid), POINTER   :: pt_grid
171    INTEGER,INTENT(IN)    :: rank
172    TYPE(domain), POINTER :: Pt_domain
173   
174    INTEGER :: Pos
175   
176    CALL vector_domain__get_new(pt_grid%subdomain,pt_domain,Pos)
177    CALL sorted_list__add(pt_grid%rank_ids,rank,Pos)
178    CALL domain__new(pt_domain)
179   
180  END SUBROUTINE grid__get_new_subdomain   
181
182  SUBROUTINE grid__get_subdomain(Pt_grid,rank,pt_domain)
183  IMPLICIT NONE
184    TYPE(grid), POINTER     :: pt_grid
185    INTEGER,INTENT(IN)      :: rank
186    TYPE(domain), POINTER   :: Pt_domain
187
188    INTEGER    :: rank_id
189    LOGICAL    :: success
190
191    CALL sorted_list__find(pt_grid%rank_ids,rank,rank_id,success)
192    IF (success) THEN
193      pt_domain=>pt_grid%subdomain%at(rank_id)%pt
194    ELSE
195      !! message d'erreur
196   ENDIF
197
198  END SUBROUTINE grid__get_subdomain
199   
200  SUBROUTINE grid__process_domain(Pt_grid)
201  IMPLICIT NONE
202    TYPE(grid), POINTER  :: pt_grid
203    TYPE(domain),POINTER :: subdomain
204    TYPE(zoom),POINTER :: pt_zoom
205   
206    REAL,ALLOCATABLE :: lon(:,:)
207    REAL,ALLOCATABLE :: lat(:,:)
208    INTEGER :: ib,ie,jb,je,ni,nj,ibegin,jbegin,iend,jend
209    INTEGER :: i
210   
211      ALLOCATE(pt_grid%ranks(1:pt_grid%subdomain%size))
212
213      DO i=1,pt_grid%subdomain%size
214        subdomain=>pt_grid%subdomain%at(i)%pt
215        IF (i==1) THEN
216          ib=subdomain%ibegin
217          ie=subdomain%iend   
218          jb=subdomain%jbegin
219          je=subdomain%jend
220        ELSE
221          IF (subdomain%ibegin<ib) ib=subdomain%ibegin
222          IF (subdomain%iend>ie) ie=subdomain%iend
223          IF (subdomain%jbegin<jb) jb=subdomain%jbegin
224          IF (subdomain%jend>je) je=subdomain%jend
225        ENDIF
226        pt_grid%ranks(subdomain%rank)=i
227      ENDDO
228     
229      ni=ie-ib+1
230      nj=je-jb+1
231      ibegin=ib
232      jbegin=jb
233     
234      ALLOCATE(lon(ni,nj))
235      ALLOCATE(lat(ni,nj))
236     
237      DO i=1,pt_grid%subdomain%size
238        subdomain=>pt_grid%subdomain%at(i)%pt
239        ib=subdomain%ibegin-ibegin+1
240        ie=subdomain%iend-ibegin+1   
241        jb=subdomain%jbegin-jbegin+1
242        je=subdomain%jend-jbegin+1
243        lon(ib:ie,jb:je)=subdomain%lon(:,:)
244        lat(ib:ie,jb:je)=subdomain%lat(:,:)
245      ENDDO
246     
247      CALL domain__set(pt_grid%domain,0,ni,nj,ibegin,jbegin,lon,lat)
248      iend=ibegin+ni-1
249      jend=jbegin+nj-1
250     
251     
252      pt_grid%global_zoom%ni_glo=pt_grid%ni
253      pt_grid%global_zoom%nj_glo=pt_grid%nj
254      pt_grid%global_zoom%ibegin_glo=1     
255      pt_grid%global_zoom%jbegin_glo=1
256     
257      DO i=1,pt_grid%associated_zoom%size
258        pt_zoom=>pt_grid%associated_zoom%at(i)%pt
259       
260        ib=MAX(pt_zoom%ibegin_glo-ibegin+1,1)
261        ie=MIN(pt_zoom%ibegin_glo+pt_zoom%ni_glo-ibegin,ni)
262        pt_zoom%ni_loc=MAX(ie-ib+1,0)
263        pt_zoom%ibegin_loc=ib
264
265        jb=MAX(pt_zoom%jbegin_glo-jbegin+1,1)
266        je=MIN(pt_zoom%jbegin_glo+pt_zoom%nj_glo-jbegin,nj)
267        pt_zoom%nj_loc=MAX(je-jb+1,0)
268        pt_zoom%jbegin_loc=jb
269      ENDDO
270                 
271           
272      DEALLOCATE(lon)
273      DEALLOCATE(lat)
274     
275    END SUBROUTINE grid__process_domain
276     
277           
278  SUBROUTINE grid__get_new_zoom(pt_grid,pt_zoom,zoom_id)
279  USE string_function
280  IMPLICIT NONE
281    TYPE(grid), POINTER                      :: pt_grid
282    TYPE(zoom),POINTER                       :: pt_zoom
283    CHARACTER(LEN=*),INTENT(IN),OPTIONAL     :: zoom_id
284    LOGICAL                                  :: success
285   
286     CALL vector_zoom__get_new(pt_grid%associated_zoom,Pt_zoom)
287     CALL zoom__new(Pt_zoom,zoom_id)
288   
289   END SUBROUTINE grid__get_new_zoom
290     
291  SUBROUTINE grid__print(pt_grid)
292  IMPLICIT NONE
293    TYPE(grid), POINTER  :: pt_grid
294    INTEGER              :: i
295   
296    PRINT *,"---- GRID ----"
297   
298    IF (pt_grid%has_id) THEN
299      PRINT *,"id = ",TRIM(pt_grid%id)
300    ELSE
301      PRINT *,"id undefined"
302    ENDIF
303   
304    IF (pt_grid%has_name) THEN
305      PRINT *,"name = ",TRIM(pt_grid%name)
306    ELSE
307      PRINT *,"name undefined"
308    ENDIF
309   
310    IF (pt_grid%has_description) THEN
311      PRINT *,"description = ",TRIM(pt_grid%description)
312    ELSE
313      PRINT *,"description undefined"
314    ENDIF
315   
316    IF (pt_grid%has_dimension) THEN
317      PRINT *,"Global grid dimension :"
318      PRINT *,"   ni =",pt_grid%ni
319      PRINT *,"   nj =",pt_grid%nj
320    ELSE
321      PRINT *,"Global dimension ni, nj undefined"
322    ENDIF
323   
324    PRINT *,"grid domain :"
325    CALL domain__print(pt_grid%domain)
326   
327    PRINT *,"grid subdomain :",pt_grid%subdomain%size
328   
329    DO i=1,pt_grid%subdomain%size
330      CALL domain__print(pt_grid%subdomain%at(i)%pt)
331    ENDDO
332   
333    PRINT *,"--------------"
334   
335  END SUBROUTINE grid__print
336
337  SUBROUTINE grid__apply_default(pt_grid_default, pt_grid_in, pt_grid_out)
338
339    TYPE(grid), POINTER :: pt_grid_default, pt_grid_in, pt_grid_out
340
341    IF (pt_grid_in%has_name) THEN
342        pt_grid_out%name=pt_grid_in%name
343        pt_grid_out%has_name=.TRUE.
344    ELSE IF ( pt_grid_default%has_name) THEN
345        pt_grid_out%name=pt_grid_default%name
346        pt_grid_out%has_name=.TRUE.
347    ELSE
348        pt_grid_out%has_name=.FALSE.
349    ENDIF
350       
351    IF (pt_grid_in%has_description) THEN
352        pt_grid_out%description=pt_grid_in%description
353        pt_grid_out%has_description=.TRUE.
354    ELSE IF ( pt_grid_default%has_description ) THEN
355        pt_grid_out%description=pt_grid_default%description
356        pt_grid_out%has_description=.TRUE.
357    ELSE
358        pt_grid_out%has_description=.FALSE.
359    ENDIF
360 
361  END SUBROUTINE grid__apply_default
362
363END MODULE mod_grid
Note: See TracBrowser for help on using the repository browser.