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

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

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