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

Last change on this file since 42 was 42, checked in by ymipsl, 15 years ago

Correction bug sur les ids des file_group
+ possibilité de fixer les attributs des groupes à partir de l'ioserver

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