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

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

devel : refactored base/field.f90
File size: 14.3 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      ELSE
136        field(ind)%ndim=2
137      END IF
138   
139      field(ind)%data_type=data_type
140      field(ind)%field_type=field_type
141
142      CALL allocate_field_XvalY(field(ind), dom(ind))
143     END DO
144   
145 END SUBROUTINE allocate_field_
146
147  SUBROUTINE allocate_field_XvalY(field, dom)
148    USE domain_mod, ONLY : t_domain
149    USE grid_param
150    TYPE(t_field) :: field
151    TYPE(t_domain), INTENT(IN) :: dom
152    INTEGER :: data_type, dim1, dim2, ij_size
153    data_type = field%data_type
154    dim1      = field%dim3
155    dim2      = field%dim4
156    SELECT CASE(grid_type)
157    CASE(grid_ico)
158       ij_size=dom%iim
159       SELECT CASE(field%field_type)
160       CASE(field_T)
161          ij_size=ij_size*dom%jjm
162       CASE(field_U)
163          ij_size=3*ij_size*dom%jjm
164       CASE(field_Z)
165          ij_size=2*ij_size*dom%jjm
166       END SELECT
167       
168       IF (field%ndim==4) THEN
169          IF (data_type==type_integer) ALLOCATE(field%ival4d(ij_size,dim1,dim2))
170          IF (data_type==type_real)    ALLOCATE(field%rval4d(ij_size,dim1,dim2))
171          IF (data_type==type_logical) ALLOCATE(field%lval4d(ij_size,dim1,dim2))
172       ELSE IF (field%ndim==3) THEN
173          IF (data_type==type_integer) ALLOCATE(field%ival3d(ij_size,dim1))
174          IF (data_type==type_real)    ALLOCATE(field%rval3d(ij_size,dim1))
175          IF (data_type==type_logical) ALLOCATE(field%lval3d(ij_size,dim1))
176       ELSE IF (field%ndim==2) THEN
177          IF (data_type==type_integer) ALLOCATE(field%ival2d(ij_size))
178          IF (data_type==type_real)    ALLOCATE(field%rval2d(ij_size))
179          IF (data_type==type_logical) ALLOCATE(field%lval2d(ij_size))
180       ENDIF
181       
182    CASE(grid_unst)
183       PRINT *, 'Allocating field ', field%name
184       SELECT CASE(field%field_type)
185       CASE(field_T)
186          ij_size=primal_num
187       CASE(field_U)
188          ij_size=edge_num
189       CASE(field_Z)
190          ij_size=dual_num
191       END SELECT
192
193       PRINT *, 'Allocating field ', field%name
194       PRINT *, '          with ij_size = ', ij_size
195       
196       IF (field%ndim==4) THEN
197          IF (data_type==type_integer) ALLOCATE(field%ival4d(dim1,ij_size,dim2))
198          IF (data_type==type_real)    ALLOCATE(field%rval4d(dim1,ij_size,dim2))
199          IF (data_type==type_logical) ALLOCATE(field%lval4d(dim1,ij_size,dim2))
200       ELSE IF (field%ndim==3) THEN
201          IF (data_type==type_integer) ALLOCATE(field%ival3d(dim1,ij_size))
202          IF (data_type==type_real)    ALLOCATE(field%rval3d(dim1,ij_size))
203          IF (data_type==type_logical) ALLOCATE(field%lval3d(dim1,ij_size))
204       ELSE IF (field%ndim==2) THEN
205          IF (data_type==type_integer) ALLOCATE(field%ival2d(ij_size))
206          IF (data_type==type_real)    ALLOCATE(field%rval2d(ij_size))
207          IF (data_type==type_logical) ALLOCATE(field%lval2d(ij_size))
208       ENDIF
209       
210    END SELECT
211  END SUBROUTINE allocate_field_XvalY
212
213  SUBROUTINE deallocate_field(field)
214    USE domain_mod
215    USE omp_para
216    IMPLICIT NONE
217    TYPE(t_field),POINTER :: field(:)
218    !$OMP BARRIER
219    CALL deallocate_field_(assigned_domain, field)
220    !$OMP BARRIER
221    !$OMP MASTER
222    DEALLOCATE(field)
223    !$OMP END MASTER
224    !$OMP BARRIER
225  END SUBROUTINE deallocate_field
226 
227  SUBROUTINE deallocate_fields(field)
228    USE domain_mod
229    USE omp_para
230    IMPLICIT NONE
231    TYPE(t_field),POINTER :: field(:,:)
232    INTEGER :: i
233    !$OMP BARRIER
234    DO i=1,SIZE(field,2)
235       CALL deallocate_field_(assigned_domain, field(:,i))
236    END DO
237    !$OMP BARRIER
238    !$OMP MASTER
239    DEALLOCATE(field)
240    !$OMP END MASTER
241    !$OMP BARRIER
242  END SUBROUTINE deallocate_fields
243
244  SUBROUTINE deallocate_field_(assigned_dom, field)
245  USE omp_para
246    IMPLICIT NONE
247    LOGICAL, INTENT(IN) :: assigned_dom(:)
248    TYPE(t_field) :: field(:)
249    INTEGER :: data_type
250    INTEGER :: ind
251    DO ind=1,SIZE(field)
252      IF (.NOT. assigned_dom(ind)  .OR. .NOT. is_omp_level_master) CYCLE
253
254      data_type=field(ind)%data_type
255       
256      IF (field(ind)%ndim==4) THEN
257        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
258        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
259        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
260      ELSE IF (field(ind)%ndim==3) THEN
261        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
262        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
263        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
264      ELSE IF (field(ind)%ndim==2) THEN
265        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
266        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
267        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
268      ENDIF
269     
270   ENDDO
271  END SUBROUTINE deallocate_field_
272
273  SUBROUTINE deallocate_field_glo(field)
274  USE domain_mod
275  IMPLICIT NONE
276    TYPE(t_field),POINTER :: field(:)
277    INTEGER :: data_type
278    INTEGER :: ind
279    LOGICAL :: assigned_dom(ndomain_glo)
280    ! ONLY the master thread is allowed to call this routine
281    CALL deallocate_field_(assigned_dom, field)
282    DEALLOCATE(field)       
283  END SUBROUTINE deallocate_field_glo
284   
285  SUBROUTINE extract_slice(field_in, field_out, l) 
286  USE domain_mod
287  USE omp_para
288  IMPLICIT NONE 
289    TYPE(t_field) :: field_in(:)
290    TYPE(t_field) :: field_out(:)
291    INTEGER,INTENT(IN) :: l
292   
293    INTEGER :: ind
294    INTEGER :: data_type
295
296!$OMP BARRIER
297    DO ind=1,ndomain
298      data_type=field_in(ind)%data_type
299      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
300     
301      IF (field_in(ind)%ndim==3 .AND. field_out(ind)%ndim==2) THEN 
302        IF (data_type==type_integer)  field_out(ind)%ival2d=field_in(ind)%ival3d(:,l)
303        IF (data_type==type_real)     field_out(ind)%rval2d=field_in(ind)%rval3d(:,l)
304        IF (data_type==type_logical)  field_out(ind)%lval2d=field_in(ind)%lval3d(:,l)
305      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
306        IF (data_type==type_integer)  field_out(ind)%ival3d=field_in(ind)%ival4d(:,:,l)
307        IF (data_type==type_real)     field_out(ind)%rval3d=field_in(ind)%rval4d(:,:,l)
308        IF (data_type==type_logical)  field_out(ind)%lval3d=field_in(ind)%lval4d(:,:,l)
309      ELSE
310        PRINT *, 'extract_slice : cannot extract slice, dimension incompatible'
311        STOP       
312      ENDIF
313   ENDDO 
314!$OMP BARRIER   
315  END  SUBROUTINE extract_slice 
316 
317 
318  SUBROUTINE insert_slice(field_in, field_out, l) 
319  USE domain_mod
320  USE omp_para
321  IMPLICIT NONE 
322    TYPE(t_field) :: field_in(:)
323    TYPE(t_field) :: field_out(:)
324    INTEGER,INTENT(IN) :: l
325   
326    INTEGER :: ind
327    INTEGER :: data_type
328
329!$OMP BARRIER
330    DO ind=1,ndomain
331      data_type=field_in(ind)%data_type
332      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
333     
334      IF (field_in(ind)%ndim==2 .AND. field_out(ind)%ndim==3) THEN 
335        IF (data_type==type_integer)  field_out(ind)%ival3d(:,l)=field_in(ind)%ival2d(:)
336        IF (data_type==type_real)     field_out(ind)%rval3d(:,l)=field_in(ind)%rval2d(:)
337        IF (data_type==type_logical)  field_out(ind)%lval3d(:,l)=field_in(ind)%lval2d(:)
338      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
339        IF (data_type==type_integer)  field_out(ind)%ival4d(:,:,l)=field_out(ind)%ival3d(:,:)
340        IF (data_type==type_real)     field_out(ind)%rval4d(:,:,l)=field_out(ind)%rval3d(:,:)
341        IF (data_type==type_logical)  field_out(ind)%lval4d(:,:,l)=field_out(ind)%lval3d(:,:)
342      ELSE
343        PRINT *, 'extract_slice : cannot insert slice, dimension incompatible'
344        STOP       
345      ENDIF
346   ENDDO 
347!$OMP BARRIER   
348 
349  END SUBROUTINE insert_slice
350   
351  SUBROUTINE getval_r2d(field_pt,field)
352  IMPLICIT NONE 
353    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
354    TYPE(t_field),INTENT(IN) :: field
355   
356    IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
357       PRINT *, 'get_val_r2d : bad pointer assignment with ' // TRIM(field%name) 
358       STOP
359    END IF
360    field_pt=>field%rval2d
361  END SUBROUTINE  getval_r2d
362
363  SUBROUTINE getval_r3d(field_pt,field)
364  IMPLICIT NONE 
365    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:)
366    TYPE(t_field),INTENT(IN) :: field
367   
368    IF (field%ndim/=3 .OR. field%data_type/=type_real) THEN
369       PRINT *, 'get_val_r3d : bad pointer assignment with ' // TRIM(field%name) 
370       STOP
371!       CALL ABORT
372    END IF
373    field_pt=>field%rval3d
374  END SUBROUTINE  getval_r3d
375
376  SUBROUTINE getval_r4d(field_pt,field)
377  IMPLICIT NONE 
378    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
379    TYPE(t_field),INTENT(IN) :: field
380   
381    IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
382       PRINT *, 'get_val_r4d : bad pointer assignment with ' // TRIM(field%name)
383       STOP
384    END IF
385    field_pt=>field%rval4d
386  END SUBROUTINE  getval_r4d 
387
388 
389  SUBROUTINE getval_i2d(field_pt,field)
390  IMPLICIT NONE 
391    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
392    TYPE(t_field),INTENT(IN) :: field
393   
394    IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignment'       
395    field_pt=>field%ival2d
396  END SUBROUTINE  getval_i2d
397
398  SUBROUTINE getval_i3d(field_pt,field)
399  IMPLICIT NONE 
400    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
401    TYPE(t_field),INTENT(IN) :: field
402   
403    IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignment'       
404    field_pt=>field%ival3d
405  END SUBROUTINE  getval_i3d
406
407  SUBROUTINE getval_i4d(field_pt,field)
408  IMPLICIT NONE 
409    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
410    TYPE(t_field),INTENT(IN) :: field
411   
412    IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignment'       
413    field_pt=>field%ival4d
414  END SUBROUTINE  getval_i4d
415
416  SUBROUTINE getval_l2d(field_pt,field)
417  IMPLICIT NONE 
418    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
419    TYPE(t_field),INTENT(IN) :: field
420   
421    IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignment'       
422    field_pt=>field%lval2d
423  END SUBROUTINE  getval_l2d
424
425  SUBROUTINE getval_l3d(field_pt,field)
426  IMPLICIT NONE 
427    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
428    TYPE(t_field),INTENT(IN) :: field
429   
430    IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignment'       
431    field_pt=>field%lval3d
432  END SUBROUTINE  getval_l3d
433
434  SUBROUTINE getval_l4d(field_pt,field)
435  IMPLICIT NONE 
436    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
437    TYPE(t_field),INTENT(IN) :: field
438   
439    IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignment'       
440    field_pt=>field%lval4d
441  END SUBROUTINE  getval_l4d   
442
443END MODULE field_mod   
Note: See TracBrowser for help on using the repository browser.