Context Navigation

source: codes/icosagcm/trunk/src/field.f90 @ 342

Last change on this file since 342 was 295, checked in by ymipsl, 10 years ago

Merging OpenMP parallisme mode : by subdomain and on vertical level.
This feature is actually experimental but may be retro-compatible with the last method based only on subdomain

YM

File size: 10.7 KB

Rev	Line
[12]	1	MODULE field_mod
	2	USE genmod
	3
	4	INTEGER,PARAMETER :: field_T=1
	5	INTEGER,PARAMETER :: field_U=2
	6	INTEGER,PARAMETER :: field_Z=3
	7
	8	INTEGER,PARAMETER :: type_integer=1
	9	INTEGER,PARAMETER :: type_real=2
	10	INTEGER,PARAMETER :: type_logical=3
	11
	12	TYPE t_field
[138]	13	CHARACTER(30) :: name
[12]	14	REAL(rstd),POINTER :: rval2d(:)
	15	REAL(rstd),POINTER :: rval3d(:,:)
	16	REAL(rstd),POINTER :: rval4d(:,:,:)
	17
	18	INTEGER,POINTER :: ival2d(:)
	19	INTEGER,POINTER :: ival3d(:,:)
	20	INTEGER,POINTER :: ival4d(:,:,:)
	21
	22	LOGICAL,POINTER :: lval2d(:)
	23	LOGICAL,POINTER :: lval3d(:,:)
	24	LOGICAL,POINTER :: lval4d(:,:,:)
	25
	26	INTEGER :: ndim
	27	INTEGER :: field_type
	28	INTEGER :: data_type
[26]	29	INTEGER :: dim3
	30	INTEGER :: dim4
[12]	31	END TYPE t_field
	32
	33	INTERFACE get_val
	34	MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
	35	getval_i2d,getval_i3d,getval_i4d, &
	36	getval_l2d,getval_l3d,getval_l4d
	37	END INTERFACE
	38
	39	INTERFACE ASSIGNMENT(=)
	40	MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
	41	getval_i2d,getval_i3d,getval_i4d, &
	42	getval_l2d,getval_l3d,getval_l4d
	43	END INTERFACE
	44
	45
	46	CONTAINS
	47
[138]	48	SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2,name)
[12]	49	USE domain_mod
[295]	50	USE omp_para
[12]	51	IMPLICIT NONE
	52	TYPE(t_field),POINTER :: field(:)
	53	INTEGER,INTENT(IN) :: field_type
	54	INTEGER,INTENT(IN) :: data_type
	55	INTEGER,OPTIONAL :: dim1,dim2
[138]	56	CHARACTER(*), OPTIONAL :: name
[12]	57	INTEGER :: ind
	58	INTEGER :: ii_size,jj_size
	59
[186]	60	!$OMP BARRIER
	61	!$OMP MASTER
[138]	62	ALLOCATE(field(ndomain))
[186]	63	!$OMP END MASTER
	64	!$OMP BARRIER
[12]	65
	66	DO ind=1,ndomain
[295]	67	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
[186]	68
[138]	69	IF(PRESENT(name)) THEN
	70	field(ind)%name = name
	71	ELSE
[159]	72	field(ind)%name = '(undefined)'
[138]	73	END IF
	74
[12]	75	IF (PRESENT(dim2)) THEN
	76	field(ind)%ndim=4
[26]	77	field(ind)%dim4=dim2
[29]	78	field(ind)%dim3=dim1
[12]	79	ELSE IF (PRESENT(dim1)) THEN
	80	field(ind)%ndim=3
[26]	81	field(ind)%dim3=dim1
[12]	82	ELSE
	83	field(ind)%ndim=2
	84	ENDIF
	85
	86
	87	field(ind)%data_type=data_type
	88	field(ind)%field_type=field_type
	89
	90	IF (field_type==field_T) THEN
	91	jj_size=domain(ind)%jjm
	92	ELSE IF (field_type==field_U) THEN
	93	jj_size=3*domain(ind)%jjm
	94	ELSE IF (field_type==field_Z) THEN
	95	jj_size=2*domain(ind)%jjm
	96	ENDIF
	97
	98	ii_size=domain(ind)%iim
	99
	100	IF (field(ind)%ndim==4) THEN
	101	IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
	102	IF (data_type==type_real) ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
	103	IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
	104	ELSE IF (field(ind)%ndim==3) THEN
	105	IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
	106	IF (data_type==type_real) ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
	107	IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
	108	ELSE IF (field(ind)%ndim==2) THEN
	109	IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
	110	IF (data_type==type_real) ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
	111	IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
	112	ENDIF
	113
	114	ENDDO
[186]	115	!$OMP BARRIER
[12]	116
	117	END SUBROUTINE allocate_field
[26]	118
[266]	119	SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name)
[26]	120	USE domain_mod
	121	IMPLICIT NONE
	122	TYPE(t_field),POINTER :: field(:)
	123	INTEGER,INTENT(IN) :: field_type
	124	INTEGER,INTENT(IN) :: data_type
	125	INTEGER,OPTIONAL :: dim1,dim2
[266]	126	CHARACTER(*), OPTIONAL :: name
[26]	127	INTEGER :: ind
	128	INTEGER :: ii_size,jj_size
	129
	130	ALLOCATE(field(ndomain_glo))
	131
	132	DO ind=1,ndomain_glo
[12]	133
[26]	134	IF (PRESENT(dim2)) THEN
	135	field(ind)%ndim=4
	136	field(ind)%dim4=dim2
[29]	137	field(ind)%dim3=dim1
[26]	138	ELSE IF (PRESENT(dim1)) THEN
	139	field(ind)%ndim=3
	140	field(ind)%dim3=dim1
	141	ELSE
	142	field(ind)%ndim=2
	143	ENDIF
	144
[266]	145	IF(PRESENT(name)) THEN
	146	field(ind)%name = name
	147	ELSE
	148	field(ind)%name = '(undefined)'
	149	END IF
[26]	150
	151	field(ind)%data_type=data_type
	152	field(ind)%field_type=field_type
	153
	154	IF (field_type==field_T) THEN
	155	jj_size=domain_glo(ind)%jjm
	156	ELSE IF (field_type==field_U) THEN
	157	jj_size=3*domain_glo(ind)%jjm
	158	ELSE IF (field_type==field_Z) THEN
	159	jj_size=2*domain_glo(ind)%jjm
	160	ENDIF
	161
	162	ii_size=domain_glo(ind)%iim
	163
	164	IF (field(ind)%ndim==4) THEN
	165	IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
	166	IF (data_type==type_real) ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
	167	IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
	168	ELSE IF (field(ind)%ndim==3) THEN
	169	IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
	170	IF (data_type==type_real) ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
	171	IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
	172	ELSE IF (field(ind)%ndim==2) THEN
	173	IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
	174	IF (data_type==type_real) ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
	175	IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
	176	ENDIF
	177
	178	ENDDO
	179
	180	END SUBROUTINE allocate_field_glo
	181
	182	SUBROUTINE deallocate_field(field)
	183	USE domain_mod
[295]	184	USE omp_para
[26]	185	IMPLICIT NONE
	186	TYPE(t_field),POINTER :: field(:)
	187	INTEGER :: data_type
	188	INTEGER :: ind
	189
[266]	190	!$OMP BARRIER
[26]	191	DO ind=1,ndomain
[295]	192	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
[26]	193
	194	data_type=field(ind)%data_type
	195
	196	IF (field(ind)%ndim==4) THEN
	197	IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
	198	IF (data_type==type_real) DEALLOCATE(field(ind)%rval4d)
	199	IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
	200	ELSE IF (field(ind)%ndim==3) THEN
	201	IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
	202	IF (data_type==type_real) DEALLOCATE(field(ind)%rval3d)
	203	IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
	204	ELSE IF (field(ind)%ndim==2) THEN
	205	IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
	206	IF (data_type==type_real) DEALLOCATE(field(ind)%rval2d)
	207	IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
	208	ENDIF
	209
	210	ENDDO
[266]	211	!$OMP BARRIER
	212	!$OMP MASTER
[26]	213	DEALLOCATE(field)
[266]	214	!$OMP END MASTER
	215	!$OMP BARRIER
[26]	216
	217	END SUBROUTINE deallocate_field
	218
	219	SUBROUTINE deallocate_field_glo(field)
	220	USE domain_mod
	221	IMPLICIT NONE
	222	TYPE(t_field),POINTER :: field(:)
	223	INTEGER :: data_type
	224	INTEGER :: ind
	225
	226	DO ind=1,ndomain_glo
	227
	228	data_type=field(ind)%data_type
	229
	230	IF (field(ind)%ndim==4) THEN
	231	IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
	232	IF (data_type==type_real) DEALLOCATE(field(ind)%rval4d)
	233	IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
	234	ELSE IF (field(ind)%ndim==3) THEN
	235	IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
	236	IF (data_type==type_real) DEALLOCATE(field(ind)%rval3d)
	237	IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
	238	ELSE IF (field(ind)%ndim==2) THEN
	239	IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
	240	IF (data_type==type_real) DEALLOCATE(field(ind)%rval2d)
	241	IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
	242	ENDIF
	243
	244	ENDDO
	245	DEALLOCATE(field)
	246
	247	END SUBROUTINE deallocate_field_glo
	248
[12]	249	SUBROUTINE getval_r2d(field_pt,field)
	250	IMPLICIT NONE
	251	REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
	252	TYPE(t_field),INTENT(IN) :: field
	253
[138]	254	IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
[159]	255	PRINT *, 'get_val_r2d : bad pointer assignment with ' // TRIM(field%name)
[138]	256	STOP
	257	END IF
[12]	258	field_pt=>field%rval2d
	259	END SUBROUTINE getval_r2d
	260
	261	SUBROUTINE getval_r3d(field_pt,field)
	262	IMPLICIT NONE
	263	REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:)
	264	TYPE(t_field),INTENT(IN) :: field
	265
[138]	266	IF (field%ndim/=3 .OR. field%data_type/=type_real) THEN
[159]	267	PRINT *, 'get_val_r3d : bad pointer assignment with ' // TRIM(field%name)
[138]	268	STOP
[159]	269	! CALL ABORT
[138]	270	END IF
[12]	271	field_pt=>field%rval3d
	272	END SUBROUTINE getval_r3d
	273
	274	SUBROUTINE getval_r4d(field_pt,field)
	275	IMPLICIT NONE
	276	REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
	277	TYPE(t_field),INTENT(IN) :: field
	278
[138]	279	IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
[159]	280	PRINT *, 'get_val_r4d : bad pointer assignment with ' // TRIM(field%name)
[138]	281	STOP
	282	END IF
[12]	283	field_pt=>field%rval4d
[138]	284	END SUBROUTINE getval_r4d
[12]	285
	286
	287	SUBROUTINE getval_i2d(field_pt,field)
	288	IMPLICIT NONE
	289	INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
	290	TYPE(t_field),INTENT(IN) :: field
	291
[159]	292	IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignment'
[12]	293	field_pt=>field%ival2d
	294	END SUBROUTINE getval_i2d
	295
	296	SUBROUTINE getval_i3d(field_pt,field)
	297	IMPLICIT NONE
	298	INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
	299	TYPE(t_field),INTENT(IN) :: field
	300
[159]	301	IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignment'
[12]	302	field_pt=>field%ival3d
	303	END SUBROUTINE getval_i3d
	304
	305	SUBROUTINE getval_i4d(field_pt,field)
	306	IMPLICIT NONE
	307	INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
	308	TYPE(t_field),INTENT(IN) :: field
	309
[159]	310	IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignment'
[12]	311	field_pt=>field%ival4d
	312	END SUBROUTINE getval_i4d
	313
	314	SUBROUTINE getval_l2d(field_pt,field)
	315	IMPLICIT NONE
	316	LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
	317	TYPE(t_field),INTENT(IN) :: field
	318
[159]	319	IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignment'
[12]	320	field_pt=>field%lval2d
	321	END SUBROUTINE getval_l2d
	322
	323	SUBROUTINE getval_l3d(field_pt,field)
	324	IMPLICIT NONE
	325	LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
	326	TYPE(t_field),INTENT(IN) :: field
	327
[159]	328	IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignment'
[12]	329	field_pt=>field%lval3d
	330	END SUBROUTINE getval_l3d
	331
	332	SUBROUTINE getval_l4d(field_pt,field)
	333	IMPLICIT NONE
	334	LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
	335	TYPE(t_field),INTENT(IN) :: field
	336
[159]	337	IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignment'
[12]	338	field_pt=>field%lval4d
	339	END SUBROUTINE getval_l4d
	340
	341	END MODULE field_mod

Note: See TracBrowser for help on using the repository browser.

Download in other formats: