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

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

devel : allocate_field for unstructured mesh
File size: 16.1 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_
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_(field,field_type,data_type,dim1,dim2,name)
64  END SUBROUTINE allocate_field
65
66  SUBROUTINE allocate_fields(nfield,field,field_type,data_type,dim1,dim2,name)
67  USE domain_mod
68  USE omp_para
69    INTEGER,INTENT(IN) :: nfield
70    TYPE(t_field),POINTER :: field(:,:)
71    INTEGER,INTENT(IN) :: field_type
72    INTEGER,INTENT(IN) :: data_type
73    INTEGER,OPTIONAL :: dim1,dim2
74    CHARACTER(*), OPTIONAL :: name
75    INTEGER :: i
76!$OMP BARRIER
77!$OMP MASTER
78    ALLOCATE(field(ndomain,nfield))
79!$OMP END MASTER
80!$OMP BARRIER
81    DO i=1,nfield
82       CALL allocate_field_(field(:,i),field_type,data_type,dim1,dim2,name)
83    END DO
84  END SUBROUTINE allocate_fields
85
86  SUBROUTINE allocate_field_(field,field_type,data_type,dim1,dim2,name)
87    USE domain_mod
88    USE omp_para
89    USE grid_param
90    TYPE(t_field) :: field(:)
91    INTEGER,INTENT(IN) :: field_type
92    INTEGER,INTENT(IN) :: data_type
93    INTEGER,OPTIONAL :: dim1,dim2
94    CHARACTER(*), OPTIONAL :: name
95    INTEGER :: ind
96    INTEGER :: ij_size
97
98    DO ind=1,ndomain
99      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
100
101      IF(PRESENT(name)) THEN
102         field(ind)%name = name
103      ELSE
104         field(ind)%name = '(undefined)'
105      END IF
106
107      IF (PRESENT(dim2)) THEN
108        field(ind)%ndim=4 
109        field(ind)%dim4=dim2 
110        field(ind)%dim3=dim1
111      ELSE IF (PRESENT(dim1)) THEN
112        field(ind)%ndim=3
113        field(ind)%dim3=dim1
114      ELSE
115        field(ind)%ndim=2
116      ENDIF
117   
118   
119      field(ind)%data_type=data_type
120      field(ind)%field_type=field_type
121     
122      SELECT CASE(grid_type)
123         CASE(grid_ico)
124            ij_size=domain(ind)%iim
125            IF (field_type==field_T) THEN
126               ij_size=ij_size*domain(ind)%jjm
127            ELSE IF (field_type==field_U) THEN
128               ij_size=3*ij_size*domain(ind)%jjm
129            ELSE IF (field_type==field_Z) THEN
130               ij_size=2*ij_size*domain(ind)%jjm
131            ENDIF     
132       
133            IF (field(ind)%ndim==4) THEN
134               IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ij_size,dim1,dim2))
135               IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ij_size,dim1,dim2))
136               IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ij_size,dim1,dim2))
137            ELSE IF (field(ind)%ndim==3) THEN
138               IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ij_size,dim1))
139               IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(ij_size,dim1))
140               IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ij_size,dim1))
141            ELSE IF (field(ind)%ndim==2) THEN
142               IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ij_size))
143               IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ij_size))
144               IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ij_size))
145            ENDIF
146
147         CASE(grid_unst)
148            PRINT *, 'Allocating field ', field(ind)%name
149            IF (field_type==field_T) THEN
150               ij_size=primal_num
151            ELSE IF (field_type==field_U) THEN
152               ij_size=edge_num
153            ELSE IF (field_type==field_Z) THEN
154               ij_size=dual_num
155            ENDIF     
156
157            IF (field(ind)%ndim==4) THEN
158               IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(dim1,ij_size,dim2))
159               IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(dim1,ij_size,dim2))
160               IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(dim1,ij_size,dim2))
161            ELSE IF (field(ind)%ndim==3) THEN
162               IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(dim1,ij_size))
163               IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(dim1,ij_size))
164               IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(dim1,ij_size))
165            ELSE IF (field(ind)%ndim==2) THEN
166               IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ij_size))
167               IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ij_size))
168               IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ij_size))
169            ENDIF
170
171         END SELECT
172      ENDDO
173!$OMP BARRIER
174   
175 END SUBROUTINE allocate_field_
176
177  SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name)
178  USE domain_mod
179  IMPLICIT NONE
180    TYPE(t_field),POINTER :: field(:)
181    INTEGER,INTENT(IN) :: field_type
182    INTEGER,INTENT(IN) :: data_type
183    INTEGER,OPTIONAL :: dim1,dim2
184    CHARACTER(*), OPTIONAL :: name
185    INTEGER :: ind
186    INTEGER :: ii_size,jj_size
187
188    ALLOCATE(field(ndomain_glo))   
189
190    DO ind=1,ndomain_glo
191 
192      IF (PRESENT(dim2)) THEN
193        field(ind)%ndim=4 
194        field(ind)%dim4=dim2 
195        field(ind)%dim3=dim1 
196      ELSE IF (PRESENT(dim1)) THEN
197        field(ind)%ndim=3
198        field(ind)%dim3=dim1 
199      ELSE
200        field(ind)%ndim=2
201      ENDIF
202   
203      IF(PRESENT(name)) THEN
204         field(ind)%name = name
205      ELSE
206         field(ind)%name = '(undefined)'
207      END IF
208   
209      field(ind)%data_type=data_type
210      field(ind)%field_type=field_type
211   
212      IF (field_type==field_T) THEN
213        jj_size=domain_glo(ind)%jjm
214      ELSE IF (field_type==field_U) THEN
215        jj_size=3*domain_glo(ind)%jjm
216      ELSE IF (field_type==field_Z) THEN
217        jj_size=2*domain_glo(ind)%jjm
218      ENDIF
219     
220      ii_size=domain_glo(ind)%iim
221       
222      IF (field(ind)%ndim==4) THEN
223        IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
224        IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
225        IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
226      ELSE IF (field(ind)%ndim==3) THEN
227        IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
228        IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
229        IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
230      ELSE IF (field(ind)%ndim==2) THEN
231        IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
232        IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
233        IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
234      ENDIF
235     
236   ENDDO
237 
238  END SUBROUTINE allocate_field_glo
239
240  SUBROUTINE deallocate_field(field)
241    USE domain_mod
242    USE omp_para
243    IMPLICIT NONE
244    TYPE(t_field),POINTER :: field(:)
245    !$OMP BARRIER
246    CALL deallocate_field_(field)
247    !$OMP BARRIER
248    !$OMP MASTER
249    DEALLOCATE(field)
250    !$OMP END MASTER
251    !$OMP BARRIER
252  END SUBROUTINE deallocate_field
253 
254  SUBROUTINE deallocate_fields(field)
255    USE domain_mod
256    USE omp_para
257    IMPLICIT NONE
258    TYPE(t_field),POINTER :: field(:,:)
259    INTEGER :: i
260    !$OMP BARRIER
261    DO i=1,SIZE(field,2)
262       CALL deallocate_field_(field(:,i))
263    END DO
264    !$OMP BARRIER
265    !$OMP MASTER
266    DEALLOCATE(field)
267    !$OMP END MASTER
268    !$OMP BARRIER
269  END SUBROUTINE deallocate_fields
270
271  SUBROUTINE deallocate_field_(field)
272  USE domain_mod
273  USE omp_para
274  IMPLICIT NONE
275    TYPE(t_field) :: field(:)
276    INTEGER :: data_type
277    INTEGER :: ind
278    DO ind=1,ndomain
279      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
280
281      data_type=field(ind)%data_type
282       
283      IF (field(ind)%ndim==4) THEN
284        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
285        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
286        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
287      ELSE IF (field(ind)%ndim==3) THEN
288        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
289        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
290        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
291      ELSE IF (field(ind)%ndim==2) THEN
292        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
293        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
294        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
295      ENDIF
296     
297   ENDDO
298  END SUBROUTINE deallocate_field_
299
300  SUBROUTINE deallocate_field_glo(field)
301  USE domain_mod
302  IMPLICIT NONE
303    TYPE(t_field),POINTER :: field(:)
304    INTEGER :: data_type
305    INTEGER :: ind
306
307    DO ind=1,ndomain_glo
308
309      data_type=field(ind)%data_type
310       
311      IF (field(ind)%ndim==4) THEN
312        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
313        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
314        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
315      ELSE IF (field(ind)%ndim==3) THEN
316        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
317        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
318        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
319      ELSE IF (field(ind)%ndim==2) THEN
320        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
321        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
322        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
323      ENDIF
324     
325   ENDDO
326   DEALLOCATE(field)
327       
328  END SUBROUTINE deallocate_field_glo
329   
330  SUBROUTINE extract_slice(field_in, field_out, l) 
331  USE domain_mod
332  USE omp_para
333  IMPLICIT NONE 
334    TYPE(t_field) :: field_in(:)
335    TYPE(t_field) :: field_out(:)
336    INTEGER,INTENT(IN) :: l
337   
338    INTEGER :: ind
339    INTEGER :: data_type
340
341!$OMP BARRIER
342    DO ind=1,ndomain
343      data_type=field_in(ind)%data_type
344      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
345     
346      IF (field_in(ind)%ndim==3 .AND. field_out(ind)%ndim==2) THEN 
347        IF (data_type==type_integer)  field_out(ind)%ival2d=field_in(ind)%ival3d(:,l)
348        IF (data_type==type_real)     field_out(ind)%rval2d=field_in(ind)%rval3d(:,l)
349        IF (data_type==type_logical)  field_out(ind)%lval2d=field_in(ind)%lval3d(:,l)
350      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
351        IF (data_type==type_integer)  field_out(ind)%ival3d=field_in(ind)%ival4d(:,:,l)
352        IF (data_type==type_real)     field_out(ind)%rval3d=field_in(ind)%rval4d(:,:,l)
353        IF (data_type==type_logical)  field_out(ind)%lval3d=field_in(ind)%lval4d(:,:,l)
354      ELSE
355        PRINT *, 'extract_slice : cannot extract slice, dimension incompatible'
356        STOP       
357      ENDIF
358   ENDDO 
359!$OMP BARRIER   
360  END  SUBROUTINE extract_slice 
361 
362 
363  SUBROUTINE insert_slice(field_in, field_out, l) 
364  USE domain_mod
365  USE omp_para
366  IMPLICIT NONE 
367    TYPE(t_field) :: field_in(:)
368    TYPE(t_field) :: field_out(:)
369    INTEGER,INTENT(IN) :: l
370   
371    INTEGER :: ind
372    INTEGER :: data_type
373
374!$OMP BARRIER
375    DO ind=1,ndomain
376      data_type=field_in(ind)%data_type
377      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
378     
379      IF (field_in(ind)%ndim==2 .AND. field_out(ind)%ndim==3) THEN 
380        IF (data_type==type_integer)  field_out(ind)%ival3d(:,l)=field_in(ind)%ival2d(:)
381        IF (data_type==type_real)     field_out(ind)%rval3d(:,l)=field_in(ind)%rval2d(:)
382        IF (data_type==type_logical)  field_out(ind)%lval3d(:,l)=field_in(ind)%lval2d(:)
383      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
384        IF (data_type==type_integer)  field_out(ind)%ival4d(:,:,l)=field_out(ind)%ival3d(:,:)
385        IF (data_type==type_real)     field_out(ind)%rval4d(:,:,l)=field_out(ind)%rval3d(:,:)
386        IF (data_type==type_logical)  field_out(ind)%lval4d(:,:,l)=field_out(ind)%lval3d(:,:)
387      ELSE
388        PRINT *, 'extract_slice : cannot insert slice, dimension incompatible'
389        STOP       
390      ENDIF
391   ENDDO 
392!$OMP BARRIER   
393 
394  END SUBROUTINE insert_slice
395   
396  SUBROUTINE getval_r2d(field_pt,field)
397  IMPLICIT NONE 
398    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
399    TYPE(t_field),INTENT(IN) :: field
400   
401    IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
402       PRINT *, 'get_val_r2d : bad pointer assignment with ' // TRIM(field%name) 
403       STOP
404    END IF
405    field_pt=>field%rval2d
406  END SUBROUTINE  getval_r2d
407
408  SUBROUTINE getval_r3d(field_pt,field)
409  IMPLICIT NONE 
410    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:)
411    TYPE(t_field),INTENT(IN) :: field
412   
413    IF (field%ndim/=3 .OR. field%data_type/=type_real) THEN
414       PRINT *, 'get_val_r3d : bad pointer assignment with ' // TRIM(field%name) 
415       STOP
416!       CALL ABORT
417    END IF
418    field_pt=>field%rval3d
419  END SUBROUTINE  getval_r3d
420
421  SUBROUTINE getval_r4d(field_pt,field)
422  IMPLICIT NONE 
423    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
424    TYPE(t_field),INTENT(IN) :: field
425   
426    IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
427       PRINT *, 'get_val_r4d : bad pointer assignment with ' // TRIM(field%name)
428       STOP
429    END IF
430    field_pt=>field%rval4d
431  END SUBROUTINE  getval_r4d 
432
433 
434  SUBROUTINE getval_i2d(field_pt,field)
435  IMPLICIT NONE 
436    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
437    TYPE(t_field),INTENT(IN) :: field
438   
439    IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignment'       
440    field_pt=>field%ival2d
441  END SUBROUTINE  getval_i2d
442
443  SUBROUTINE getval_i3d(field_pt,field)
444  IMPLICIT NONE 
445    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
446    TYPE(t_field),INTENT(IN) :: field
447   
448    IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignment'       
449    field_pt=>field%ival3d
450  END SUBROUTINE  getval_i3d
451
452  SUBROUTINE getval_i4d(field_pt,field)
453  IMPLICIT NONE 
454    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
455    TYPE(t_field),INTENT(IN) :: field
456   
457    IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignment'       
458    field_pt=>field%ival4d
459  END SUBROUTINE  getval_i4d
460
461  SUBROUTINE getval_l2d(field_pt,field)
462  IMPLICIT NONE 
463    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
464    TYPE(t_field),INTENT(IN) :: field
465   
466    IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignment'       
467    field_pt=>field%lval2d
468  END SUBROUTINE  getval_l2d
469
470  SUBROUTINE getval_l3d(field_pt,field)
471  IMPLICIT NONE 
472    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
473    TYPE(t_field),INTENT(IN) :: field
474   
475    IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignment'       
476    field_pt=>field%lval3d
477  END SUBROUTINE  getval_l3d
478
479  SUBROUTINE getval_l4d(field_pt,field)
480  IMPLICIT NONE 
481    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
482    TYPE(t_field),INTENT(IN) :: field
483   
484    IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignment'       
485    field_pt=>field%lval4d
486  END SUBROUTINE  getval_l4d   
487
488END MODULE field_mod   
Note: See TracBrowser for help on using the repository browser.