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

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

Correction de bugs pour portage sur Mercure
File size: 7.3 KB
Line 
1MODULE mod_grid
2  USE mod_xmlio_parameters
3  USE mod_sorted_list
4  USE mod_domain
5  IMPLICIT NONE
6
7  TYPE, PUBLIC :: grid
8    CHARACTER(len=str_len)      :: id
9    LOGICAL                     :: has_id
10    CHARACTER(len=str_len)      :: name
11    LOGICAL                     :: has_name
12    CHARACTER(len=str_len)      :: description
13    LOGICAL                     :: has_description
14    TYPE(domain),POINTER        :: domain
15    TYPE(vector_domain),POINTER :: subdomain
16    TYPE(sorted_list),POINTER   :: rank_ids
17    INTEGER,POINTER             :: ranks(:)
18    INTEGER                     :: ni
19    INTEGER                     :: nj
20    LOGICAL                     :: has_dimension
21  END TYPE grid
22
23  INCLUDE 'vector_grid_def.inc'
24 
25  TYPE(vector_grid),POINTER,SAVE             :: grid_Ids
26  TYPE(sorted_list),POINTER,SAVE,PRIVATE     :: Ids 
27
28CONTAINS
29  INCLUDE 'vector_grid_contains.inc'
30
31  SUBROUTINE grid__init
32  IMPLICIT NONE
33   
34    ALLOCATE(grid_Ids)
35    ALLOCATE(Ids)
36   
37    CALL vector_grid__new(grid_Ids)
38    CALL sorted_list__new(Ids)
39   
40  END SUBROUTINE grid__init
41 
42  SUBROUTINE grid__get(Id,Pt_grid)
43  USE string_function
44  IMPLICIT NONE
45    CHARACTER(LEN=*),INTENT(IN)     :: Id
46    TYPE(grid),POINTER              :: Pt_grid
47
48    INTEGER                         :: Pos
49    LOGICAL                         :: success
50   
51    CALL sorted_list__find(Ids,hash(Id),Pos,success)
52    IF (success) THEN
53      Pt_grid=>grid_ids%at(Pos)%Pt
54    ELSE
55      Pt_grid=>NULL()
56    ENDIF
57   
58  END SUBROUTINE grid__get
59 
60  SUBROUTINE grid__new(pt_grid,Id)
61  USE string_function
62  IMPLICIT NONE
63   TYPE(grid), POINTER           :: pt_grid
64   CHARACTER(LEN=*),OPTIONAL     :: Id
65   INTEGER                       :: Pos
66   
67   ALLOCATE(pt_grid%domain)
68   ALLOCATE(pt_grid%subdomain)
69   ALLOCATE(pt_grid%rank_ids)
70   CALL domain__new(pt_grid%domain)
71   CALL vector_domain__new(pt_grid%subdomain)
72   CALL sorted_list__new(pt_grid%rank_ids)
73   
74   pt_grid%has_id          = .FALSE.
75   pt_grid%has_name        = .FALSE.
76   pt_grid%has_description = .FALSE.
77   pt_grid%has_dimension   = .FALSE.
78   
79   IF (PRESENT(Id)) THEN
80     Pt_grid%id=TRIM(ADJUSTL(Id))
81     Pt_grid%has_id=.TRUE.
82     CALL vector_grid__set_new(grid_Ids,Pt_grid,Pos)
83     CALL sorted_list__Add(Ids,hash(id),Pos)
84   ENDIF
85
86 END SUBROUTINE grid__new
87
88  SUBROUTINE grid__set(pt_grid, name, description)
89  IMPLICIT NONE
90    TYPE(grid), POINTER :: pt_grid
91    CHARACTER(len=*)  ,OPTIONAL :: name
92    CHARACTER(len=*)  ,OPTIONAL :: description
93
94    IF (PRESENT(name)) THEN
95        pt_grid%name=TRIM(ADJUSTL(name))
96        pt_grid%has_name = .TRUE.
97    ENDIF
98
99    IF (PRESENT(description)) THEN
100        pt_grid%description=TRIM(ADJUSTL(description))
101        pt_grid%has_description = .TRUE.
102    ENDIF
103
104  END SUBROUTINE grid__set
105
106  SUBROUTINE grid__set_dimension(pt_grid, ni, nj)
107  IMPLICIT NONE
108    TYPE(grid), POINTER   :: pt_grid
109    INTEGER,INTENT(IN)    :: ni
110    INTEGER,INTENT(IN)    :: nj
111   
112    pt_grid%ni=ni
113    pt_grid%nj=nj
114    pt_grid%has_dimension=.TRUE.
115   
116  END SUBROUTINE grid__set_dimension
117   
118
119  SUBROUTINE grid__get_new_subdomain(Pt_grid,rank,pt_domain)
120  IMPLICIT NONE
121    TYPE(grid), POINTER   :: pt_grid
122    INTEGER,INTENT(IN)    :: rank
123    TYPE(domain), POINTER :: Pt_domain
124   
125    INTEGER :: Pos
126   
127    CALL vector_domain__get_new(pt_grid%subdomain,pt_domain,Pos)
128    CALL sorted_list__add(pt_grid%rank_ids,rank,Pos)
129    CALL domain__new(pt_domain)
130   
131  END SUBROUTINE grid__get_new_subdomain   
132
133  SUBROUTINE grid__get_subdomain(Pt_grid,rank,pt_domain)
134  IMPLICIT NONE
135    TYPE(grid), POINTER     :: pt_grid
136    INTEGER,INTENT(IN)      :: rank
137    TYPE(domain), POINTER   :: Pt_domain
138
139    INTEGER    :: rank_id
140    LOGICAL    :: success
141
142    CALL sorted_list__find(pt_grid%rank_ids,rank,rank_id,success)
143    IF (success) THEN
144      pt_domain=>pt_grid%subdomain%at(rank_id)%pt
145    ELSE
146      !! message d'erreur
147   ENDIF
148
149  END SUBROUTINE grid__get_subdomain
150   
151  SUBROUTINE grid__process_domain(Pt_grid)
152  IMPLICIT NONE
153    TYPE(grid), POINTER  :: pt_grid
154    TYPE(domain),POINTER :: subdomain
155   
156    REAL,ALLOCATABLE :: lon(:,:)
157    REAL,ALLOCATABLE :: lat(:,:)
158    INTEGER :: ib,ie,jb,je,ni,nj,ibegin,jbegin
159    INTEGER :: i
160   
161      ALLOCATE(pt_grid%ranks(1:pt_grid%subdomain%size))
162
163      DO i=1,pt_grid%subdomain%size
164        subdomain=>pt_grid%subdomain%at(i)%pt
165        IF (i==1) THEN
166          ib=subdomain%ibegin
167          ie=subdomain%iend   
168          jb=subdomain%jbegin
169          je=subdomain%jend
170        ELSE
171          IF (subdomain%ibegin<ib) ib=subdomain%ibegin
172          IF (subdomain%iend>ie) ie=subdomain%iend
173          IF (subdomain%jbegin<jb) jb=subdomain%jbegin
174          IF (subdomain%jend>je) je=subdomain%jend
175        ENDIF
176        pt_grid%ranks(subdomain%rank)=i
177      ENDDO
178     
179      ni=ie-ib+1
180      nj=je-jb+1
181      ibegin=ib
182      jbegin=jb
183     
184      ALLOCATE(lon(ni,nj))
185      ALLOCATE(lat(ni,nj))
186     
187      DO i=1,pt_grid%subdomain%size
188        subdomain=>pt_grid%subdomain%at(i)%pt
189        ib=subdomain%ibegin-ibegin+1
190        ie=subdomain%iend-ibegin+1   
191        jb=subdomain%jbegin-jbegin+1
192        je=subdomain%jend-jbegin+1
193        lon(ib:ie,jb:je)=subdomain%lon(:,:)
194        lat(ib:ie,jb:je)=subdomain%lat(:,:)
195      ENDDO
196     
197      CALL domain__set(pt_grid%domain,0,ni,nj,ibegin,jbegin,lon,lat)
198
199     
200      DEALLOCATE(lon)
201      DEALLOCATE(lat)
202     
203    END SUBROUTINE grid__process_domain
204     
205           
206       
207  SUBROUTINE grid__print(pt_grid)
208  IMPLICIT NONE
209    TYPE(grid), POINTER  :: pt_grid
210    INTEGER              :: i
211   
212    PRINT *,"---- GRID ----"
213   
214    IF (pt_grid%has_id) THEN
215      PRINT *,"id = ",TRIM(pt_grid%id)
216    ELSE
217      PRINT *,"id undefined"
218    ENDIF
219   
220    IF (pt_grid%has_name) THEN
221      PRINT *,"name = ",TRIM(pt_grid%name)
222    ELSE
223      PRINT *,"name undefined"
224    ENDIF
225   
226    IF (pt_grid%has_description) THEN
227      PRINT *,"description = ",TRIM(pt_grid%description)
228    ELSE
229      PRINT *,"description undefined"
230    ENDIF
231   
232    IF (pt_grid%has_dimension) THEN
233      PRINT *,"Global grid dimension :"
234      PRINT *,"   ni =",pt_grid%ni
235      PRINT *,"   nj =",pt_grid%nj
236    ELSE
237      PRINT *,"Global dimension ni, nj undefined"
238    ENDIF
239   
240    PRINT *,"grid domain :"
241    CALL domain__print(pt_grid%domain)
242   
243    PRINT *,"grid subdomain :",pt_grid%subdomain%size
244   
245    DO i=1,pt_grid%subdomain%size
246      CALL domain__print(pt_grid%subdomain%at(i)%pt)
247    ENDDO
248   
249    PRINT *,"--------------"
250   
251  END SUBROUTINE grid__print
252
253  SUBROUTINE grid__apply_default(pt_grid_default, pt_grid_in, pt_grid_out)
254
255    TYPE(grid), POINTER :: pt_grid_default, pt_grid_in, pt_grid_out
256
257    IF (pt_grid_in%has_name) THEN
258        pt_grid_out%name=pt_grid_in%name
259        pt_grid_out%has_name=.TRUE.
260    ELSE IF ( pt_grid_default%has_name) THEN
261        pt_grid_out%name=pt_grid_default%name
262        pt_grid_out%has_name=.TRUE.
263    ELSE
264        pt_grid_out%has_name=.FALSE.
265    ENDIF
266       
267    IF (pt_grid_in%has_description) THEN
268        pt_grid_out%description=pt_grid_in%description
269        pt_grid_out%has_description=.TRUE.
270    ELSE IF ( pt_grid_default%has_description ) THEN
271        pt_grid_out%description=pt_grid_default%description
272        pt_grid_out%has_description=.TRUE.
273    ELSE
274        pt_grid_out%has_description=.FALSE.
275    ENDIF
276 
277  END SUBROUTINE grid__apply_default
278
279END MODULE mod_grid
Note: See TracBrowser for help on using the repository browser.