source: codes/icosagcm/devel/src/base/field.f90 @ 879

Last change on this file since 879 was 879, checked in by dubos, 5 years ago

devel : introduced derived type to store cell bounds
File size: 14.4 KB
Line 
1MODULE field_mod
2  USE genmod
3  IMPLICIT NONE
4 
5  INTEGER,PARAMETER :: field_T=1
6  INTEGER,PARAMETER :: field_U=2
7  INTEGER,PARAMETER :: field_Z=3
8
9  INTEGER,PARAMETER :: type_integer=1
10  INTEGER,PARAMETER :: type_real=2
11  INTEGER,PARAMETER :: type_logical=3
12   
13  TYPE t_field
14    CHARACTER(30)      :: name
15    REAL(rstd),POINTER :: rval2d(:)
16    REAL(rstd),POINTER :: rval3d(:,:)
17    REAL(rstd),POINTER :: rval4d(:,:,:)
18
19    INTEGER,POINTER :: ival2d(:)
20    INTEGER,POINTER :: ival3d(:,:)
21    INTEGER,POINTER :: ival4d(:,:,:)
22   
23    LOGICAL,POINTER :: lval2d(:)
24    LOGICAL,POINTER :: lval3d(:,:)
25    LOGICAL,POINTER :: lval4d(:,:,:)
26
27    INTEGER :: ndim
28    INTEGER :: field_type
29    INTEGER :: data_type 
30    INTEGER :: dim3
31    INTEGER :: dim4
32  END TYPE t_field   
33
34  INTERFACE get_val
35    MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
36                     getval_i2d,getval_i3d,getval_i4d, &
37                     getval_l2d,getval_l3d,getval_l4d
38  END INTERFACE
39                   
40  INTERFACE ASSIGNMENT(=)
41    MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
42                     getval_i2d,getval_i3d,getval_i4d, &
43                     getval_l2d,getval_l3d,getval_l4d 
44  END INTERFACE
45
46  PRIVATE :: allocate_field_, deallocate_field_
47
48CONTAINS
49
50  SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2,name)
51  USE domain_mod
52  USE omp_para
53    TYPE(t_field),POINTER :: field(:)
54    INTEGER,INTENT(IN) :: field_type
55    INTEGER,INTENT(IN) :: data_type
56    INTEGER,OPTIONAL :: dim1,dim2
57    CHARACTER(*), OPTIONAL :: name
58!$OMP BARRIER
59!$OMP MASTER
60    ALLOCATE(field(ndomain))
61!$OMP END MASTER
62!$OMP BARRIER
63    CALL allocate_field_(domain,assigned_domain, field,field_type,data_type,dim1,dim2,name)
64!$OMP BARRIER
65  END SUBROUTINE allocate_field
66
67  SUBROUTINE allocate_fields(nfield,field,field_type,data_type,dim1,dim2,name)
68  USE domain_mod
69  USE omp_para
70    INTEGER,INTENT(IN) :: nfield
71    TYPE(t_field),POINTER :: field(:,:)
72    INTEGER,INTENT(IN) :: field_type
73    INTEGER,INTENT(IN) :: data_type
74    INTEGER,OPTIONAL :: dim1,dim2
75    CHARACTER(*), OPTIONAL :: name
76    INTEGER :: i
77!$OMP BARRIER
78!$OMP MASTER
79    ALLOCATE(field(ndomain,nfield))
80!$OMP END MASTER
81!$OMP BARRIER
82    DO i=1,nfield
83       CALL allocate_field_(domain,assigned_domain, field(:,i),field_type,data_type,dim1,dim2,name)
84    END DO
85!$OMP BARRIER
86  END SUBROUTINE allocate_fields
87
88  SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name)
89    USE domain_mod
90    IMPLICIT NONE
91    TYPE(t_field),POINTER :: field(:)
92    INTEGER,INTENT(IN) :: field_type
93    INTEGER,INTENT(IN) :: data_type
94    INTEGER,OPTIONAL :: dim1,dim2
95    CHARACTER(*), OPTIONAL :: name
96    INTEGER :: ind
97    INTEGER :: ii_size,jj_size
98    LOGICAL :: assigned_dom(ndomain_glo)
99    ! ONLY the master thread is allowed to call this routine
100
101    ALLOCATE(field(ndomain_glo))   
102    assigned_dom(:)=.TRUE.
103    CALL allocate_field_(domain_glo,assigned_dom, field,field_type,data_type,dim1,dim2,name) 
104
105  END SUBROUTINE allocate_field_glo
106
107  SUBROUTINE allocate_field_(dom,assigned_dom, field,field_type,data_type,dim1,dim2,name) 
108    USE domain_mod
109    USE omp_para
110    TYPE(t_domain), INTENT(IN) :: dom(:)
111    LOGICAL, INTENT(IN) :: assigned_dom(:)
112    TYPE(t_field) :: field(:)
113    INTEGER,INTENT(IN) :: field_type
114    INTEGER,INTENT(IN) :: data_type
115    INTEGER,OPTIONAL :: dim1,dim2
116    CHARACTER(*), OPTIONAL :: name
117    INTEGER :: ind
118
119    DO ind=1,SIZE(field)
120      IF (.NOT. assigned_dom(ind)  .OR. .NOT. is_omp_level_master) CYCLE
121
122      IF(PRESENT(name)) THEN
123         field(ind)%name = name
124      ELSE
125         field(ind)%name = '(undefined)'
126      END IF
127
128      IF (PRESENT(dim2)) THEN
129        field(ind)%ndim=4 
130        field(ind)%dim4=dim2 
131        field(ind)%dim3=dim1
132      ELSE IF (PRESENT(dim1)) THEN
133        field(ind)%ndim=3
134        field(ind)%dim3=dim1
135        field(ind)%dim4=1
136      ELSE
137        field(ind)%ndim=2
138        field(ind)%dim3=1
139        field(ind)%dim4=1
140      END IF
141   
142      field(ind)%data_type=data_type
143      field(ind)%field_type=field_type
144
145      CALL allocate_field_XvalY(field(ind), dom(ind))
146     END DO
147   
148 END SUBROUTINE allocate_field_
149
150  SUBROUTINE allocate_field_XvalY(field, dom)
151    USE domain_mod, ONLY : t_domain
152    USE grid_param
153    TYPE(t_field) :: field
154    TYPE(t_domain), INTENT(IN) :: dom
155    INTEGER :: data_type, dim1, dim2, ij_size
156    data_type = field%data_type
157    dim1      = field%dim3
158    dim2      = field%dim4
159    SELECT CASE(grid_type)
160    CASE(grid_ico)
161       ij_size=dom%iim
162       SELECT CASE(field%field_type)
163       CASE(field_T)
164          ij_size=ij_size*dom%jjm
165       CASE(field_U)
166          ij_size=3*ij_size*dom%jjm
167       CASE(field_Z)
168          ij_size=2*ij_size*dom%jjm
169       END SELECT
170       
171       IF (field%ndim==4) THEN
172          IF (data_type==type_integer) ALLOCATE(field%ival4d(ij_size,dim1,dim2))
173          IF (data_type==type_real)    ALLOCATE(field%rval4d(ij_size,dim1,dim2))
174          IF (data_type==type_logical) ALLOCATE(field%lval4d(ij_size,dim1,dim2))
175       ELSE IF (field%ndim==3) THEN
176          IF (data_type==type_integer) ALLOCATE(field%ival3d(ij_size,dim1))
177          IF (data_type==type_real)    ALLOCATE(field%rval3d(ij_size,dim1))
178          IF (data_type==type_logical) ALLOCATE(field%lval3d(ij_size,dim1))
179       ELSE IF (field%ndim==2) THEN
180          IF (data_type==type_integer) ALLOCATE(field%ival2d(ij_size))
181          IF (data_type==type_real)    ALLOCATE(field%rval2d(ij_size))
182          IF (data_type==type_logical) ALLOCATE(field%lval2d(ij_size))
183       ENDIF
184       
185    CASE(grid_unst)
186       PRINT *, 'Allocating field ', field%name
187       SELECT CASE(field%field_type)
188       CASE(field_T)
189          ij_size=primal_num
190       CASE(field_U)
191          ij_size=edge_num
192       CASE(field_Z)
193          ij_size=dual_num
194       END SELECT
195
196       PRINT *, 'Allocating field ', field%name
197       PRINT *, '          with ij_size = ', ij_size
198       
199       IF (field%ndim==4) THEN
200          IF (data_type==type_integer) ALLOCATE(field%ival4d(dim1,ij_size,dim2))
201          IF (data_type==type_real)    ALLOCATE(field%rval4d(dim1,ij_size,dim2))
202          IF (data_type==type_logical) ALLOCATE(field%lval4d(dim1,ij_size,dim2))
203       ELSE IF (field%ndim==3) THEN
204          IF (data_type==type_integer) ALLOCATE(field%ival3d(dim1,ij_size))
205          IF (data_type==type_real)    ALLOCATE(field%rval3d(dim1,ij_size))
206          IF (data_type==type_logical) ALLOCATE(field%lval3d(dim1,ij_size))
207       ELSE IF (field%ndim==2) THEN
208          IF (data_type==type_integer) ALLOCATE(field%ival2d(ij_size))
209          IF (data_type==type_real)    ALLOCATE(field%rval2d(ij_size))
210          IF (data_type==type_logical) ALLOCATE(field%lval2d(ij_size))
211       ENDIF
212       
213    END SELECT
214  END SUBROUTINE allocate_field_XvalY
215
216  SUBROUTINE deallocate_field(field)
217    USE domain_mod
218    USE omp_para
219    IMPLICIT NONE
220    TYPE(t_field),POINTER :: field(:)
221    !$OMP BARRIER
222    CALL deallocate_field_(assigned_domain, field)
223    !$OMP BARRIER
224    !$OMP MASTER
225    DEALLOCATE(field)
226    !$OMP END MASTER
227    !$OMP BARRIER
228  END SUBROUTINE deallocate_field
229 
230  SUBROUTINE deallocate_fields(field)
231    USE domain_mod
232    USE omp_para
233    IMPLICIT NONE
234    TYPE(t_field),POINTER :: field(:,:)
235    INTEGER :: i
236    !$OMP BARRIER
237    DO i=1,SIZE(field,2)
238       CALL deallocate_field_(assigned_domain, field(:,i))
239    END DO
240    !$OMP BARRIER
241    !$OMP MASTER
242    DEALLOCATE(field)
243    !$OMP END MASTER
244    !$OMP BARRIER
245  END SUBROUTINE deallocate_fields
246
247  SUBROUTINE deallocate_field_(assigned_dom, field)
248  USE omp_para
249    IMPLICIT NONE
250    LOGICAL, INTENT(IN) :: assigned_dom(:)
251    TYPE(t_field) :: field(:)
252    INTEGER :: data_type
253    INTEGER :: ind
254    DO ind=1,SIZE(field)
255      IF (.NOT. assigned_dom(ind)  .OR. .NOT. is_omp_level_master) CYCLE
256
257      data_type=field(ind)%data_type
258       
259      IF (field(ind)%ndim==4) THEN
260        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
261        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
262        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
263      ELSE IF (field(ind)%ndim==3) THEN
264        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
265        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
266        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
267      ELSE IF (field(ind)%ndim==2) THEN
268        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
269        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
270        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
271      ENDIF
272     
273   ENDDO
274  END SUBROUTINE deallocate_field_
275
276  SUBROUTINE deallocate_field_glo(field)
277  USE domain_mod
278  IMPLICIT NONE
279    TYPE(t_field),POINTER :: field(:)
280    INTEGER :: data_type
281    INTEGER :: ind
282    LOGICAL :: assigned_dom(ndomain_glo)
283    ! ONLY the master thread is allowed to call this routine
284    CALL deallocate_field_(assigned_dom, field)
285    DEALLOCATE(field)       
286  END SUBROUTINE deallocate_field_glo
287   
288  SUBROUTINE extract_slice(field_in, field_out, l) 
289  USE domain_mod
290  USE omp_para
291  IMPLICIT NONE 
292    TYPE(t_field) :: field_in(:)
293    TYPE(t_field) :: field_out(:)
294    INTEGER,INTENT(IN) :: l
295   
296    INTEGER :: ind
297    INTEGER :: data_type
298
299!$OMP BARRIER
300    DO ind=1,ndomain
301      data_type=field_in(ind)%data_type
302      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
303     
304      IF (field_in(ind)%ndim==3 .AND. field_out(ind)%ndim==2) THEN 
305        IF (data_type==type_integer)  field_out(ind)%ival2d=field_in(ind)%ival3d(:,l)
306        IF (data_type==type_real)     field_out(ind)%rval2d=field_in(ind)%rval3d(:,l)
307        IF (data_type==type_logical)  field_out(ind)%lval2d=field_in(ind)%lval3d(:,l)
308      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
309        IF (data_type==type_integer)  field_out(ind)%ival3d=field_in(ind)%ival4d(:,:,l)
310        IF (data_type==type_real)     field_out(ind)%rval3d=field_in(ind)%rval4d(:,:,l)
311        IF (data_type==type_logical)  field_out(ind)%lval3d=field_in(ind)%lval4d(:,:,l)
312      ELSE
313        PRINT *, 'extract_slice : cannot extract slice, dimension incompatible'
314        STOP       
315      ENDIF
316   ENDDO 
317!$OMP BARRIER   
318  END  SUBROUTINE extract_slice 
319 
320 
321  SUBROUTINE insert_slice(field_in, field_out, l) 
322  USE domain_mod
323  USE omp_para
324  IMPLICIT NONE 
325    TYPE(t_field) :: field_in(:)
326    TYPE(t_field) :: field_out(:)
327    INTEGER,INTENT(IN) :: l
328   
329    INTEGER :: ind
330    INTEGER :: data_type
331
332!$OMP BARRIER
333    DO ind=1,ndomain
334      data_type=field_in(ind)%data_type
335      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
336     
337      IF (field_in(ind)%ndim==2 .AND. field_out(ind)%ndim==3) THEN 
338        IF (data_type==type_integer)  field_out(ind)%ival3d(:,l)=field_in(ind)%ival2d(:)
339        IF (data_type==type_real)     field_out(ind)%rval3d(:,l)=field_in(ind)%rval2d(:)
340        IF (data_type==type_logical)  field_out(ind)%lval3d(:,l)=field_in(ind)%lval2d(:)
341      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
342        IF (data_type==type_integer)  field_out(ind)%ival4d(:,:,l)=field_out(ind)%ival3d(:,:)
343        IF (data_type==type_real)     field_out(ind)%rval4d(:,:,l)=field_out(ind)%rval3d(:,:)
344        IF (data_type==type_logical)  field_out(ind)%lval4d(:,:,l)=field_out(ind)%lval3d(:,:)
345      ELSE
346        PRINT *, 'extract_slice : cannot insert slice, dimension incompatible'
347        STOP       
348      ENDIF
349   ENDDO 
350!$OMP BARRIER   
351 
352  END SUBROUTINE insert_slice
353   
354  SUBROUTINE getval_r2d(field_pt,field)
355  IMPLICIT NONE 
356    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
357    TYPE(t_field),INTENT(IN) :: field
358   
359    IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
360       PRINT *, 'get_val_r2d : bad pointer assignment with ' // TRIM(field%name) 
361       STOP
362    END IF
363    field_pt=>field%rval2d
364  END SUBROUTINE  getval_r2d
365
366  SUBROUTINE getval_r3d(field_pt,field)
367  IMPLICIT NONE 
368    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:)
369    TYPE(t_field),INTENT(IN) :: field
370   
371    IF (field%ndim/=3 .OR. field%data_type/=type_real) THEN
372       PRINT *, 'get_val_r3d : bad pointer assignment with ' // TRIM(field%name) 
373       STOP
374!       CALL ABORT
375    END IF
376    field_pt=>field%rval3d
377  END SUBROUTINE  getval_r3d
378
379  SUBROUTINE getval_r4d(field_pt,field)
380  IMPLICIT NONE 
381    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
382    TYPE(t_field),INTENT(IN) :: field
383   
384    IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
385       PRINT *, 'get_val_r4d : bad pointer assignment with ' // TRIM(field%name)
386       STOP
387    END IF
388    field_pt=>field%rval4d
389  END SUBROUTINE  getval_r4d 
390
391 
392  SUBROUTINE getval_i2d(field_pt,field)
393  IMPLICIT NONE 
394    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
395    TYPE(t_field),INTENT(IN) :: field
396   
397    IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignment'       
398    field_pt=>field%ival2d
399  END SUBROUTINE  getval_i2d
400
401  SUBROUTINE getval_i3d(field_pt,field)
402  IMPLICIT NONE 
403    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
404    TYPE(t_field),INTENT(IN) :: field
405   
406    IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignment'       
407    field_pt=>field%ival3d
408  END SUBROUTINE  getval_i3d
409
410  SUBROUTINE getval_i4d(field_pt,field)
411  IMPLICIT NONE 
412    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
413    TYPE(t_field),INTENT(IN) :: field
414   
415    IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignment'       
416    field_pt=>field%ival4d
417  END SUBROUTINE  getval_i4d
418
419  SUBROUTINE getval_l2d(field_pt,field)
420  IMPLICIT NONE 
421    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
422    TYPE(t_field),INTENT(IN) :: field
423   
424    IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignment'       
425    field_pt=>field%lval2d
426  END SUBROUTINE  getval_l2d
427
428  SUBROUTINE getval_l3d(field_pt,field)
429  IMPLICIT NONE 
430    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
431    TYPE(t_field),INTENT(IN) :: field
432   
433    IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignment'       
434    field_pt=>field%lval3d
435  END SUBROUTINE  getval_l3d
436
437  SUBROUTINE getval_l4d(field_pt,field)
438  IMPLICIT NONE 
439    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
440    TYPE(t_field),INTENT(IN) :: field
441   
442    IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignment'       
443    field_pt=>field%lval4d
444  END SUBROUTINE  getval_l4d   
445
446END MODULE field_mod   
Note: See TracBrowser for help on using the repository browser.