Context Navigation

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

Last change on this file since 275 was 266, checked in by ymipsl, 10 years ago

Synchronize trunk and Saturn branch.
Merge modification from Saturn branch to trunk

YM

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

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

Download in other formats: