Context Navigation

← Previous Revision
Next Revision →
Normal
Revision Log

field.f90

Last change on this file was 1055, checked in by dubos, 4 years ago
Simplify base/field.f90 to reduce repetitive code Generate remaining repetitive code in base/field.f90 and parallel/transfert_mpi_collectives from a template
File size: 13.3 KB

Rev	Line
[12]	1	MODULE field_mod
	2	USE genmod
[350]	3	IMPLICIT NONE
[1055]	4
[12]	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
[1055]	12
[12]	13	TYPE t_field
[1055]	14	CHARACTER(30) :: name
	15	LOGICAL :: ondevice !< flag if field is allocated on device as well
	16	INTEGER :: ndim
	17	INTEGER :: field_type
	18	INTEGER :: data_type
	19	INTEGER :: dim3
	20	INTEGER :: dim4
	21	REAL(rstd), POINTER, CONTIGUOUS :: rval2d(:) => NULL()
	22	REAL(rstd), POINTER, CONTIGUOUS :: rval3d(:,:) => NULL()
	23	REAL(rstd), POINTER, CONTIGUOUS :: rval4d(:,:,:) => NULL()
	24	INTEGER, POINTER, CONTIGUOUS :: ival2d(:) => NULL()
	25	INTEGER, POINTER, CONTIGUOUS :: ival3d(:,:) => NULL()
	26	INTEGER, POINTER, CONTIGUOUS :: ival4d(:,:,:) => NULL()
	27	LOGICAL, POINTER, CONTIGUOUS :: lval2d(:) => NULL()
	28	LOGICAL, POINTER, CONTIGUOUS :: lval3d(:,:) => NULL()
	29	LOGICAL, POINTER, CONTIGUOUS :: lval4d(:,:,:) => NULL()
	30	END TYPE t_field
[1053]	31
[12]	32	INTERFACE get_val
[1055]	33	MODULE PROCEDURE getval_r2d
	34	MODULE PROCEDURE getval_r3d
	35	MODULE PROCEDURE getval_r4d
	36	MODULE PROCEDURE getval_i2d
	37	MODULE PROCEDURE getval_i3d
	38	MODULE PROCEDURE getval_i4d
	39	MODULE PROCEDURE getval_l2d
	40	MODULE PROCEDURE getval_l3d
	41	MODULE PROCEDURE getval_l4d
[12]	42	END INTERFACE
[1055]	43
[12]	44	INTERFACE ASSIGNMENT(=)
[1055]	45	MODULE PROCEDURE getval_r2d
	46	MODULE PROCEDURE getval_r3d
	47	MODULE PROCEDURE getval_r4d
	48	MODULE PROCEDURE getval_i2d
	49	MODULE PROCEDURE getval_i3d
	50	MODULE PROCEDURE getval_i4d
	51	MODULE PROCEDURE getval_l2d
	52	MODULE PROCEDURE getval_l3d
	53	MODULE PROCEDURE getval_l4d
[12]	54	END INTERFACE
	55
[1055]	56	PRIVATE :: allocate_field_, deallocate_field_
[12]	57
	58	CONTAINS
	59
[1055]	60	!====================================== allocate_field ===================================
	61
	62	SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name)
	63	USE domain_mod
[12]	64	TYPE(t_field),POINTER :: field(:)
	65	INTEGER,INTENT(IN) :: field_type
	66	INTEGER,INTENT(IN) :: data_type
	67	INTEGER,OPTIONAL :: dim1,dim2
[138]	68	CHARACTER(*), OPTIONAL :: name
[1055]	69	INTEGER :: ind
[953]	70
[1055]	71	ALLOCATE(field(ndomain_glo))
	72	DO ind=1,ndomain_glo
	73	CALL allocate_field_(domain_glo(ind), field(ind), field_type, data_type, dim1, dim2, name)
	74	ENDDO
[12]	75
[1055]	76	END SUBROUTINE allocate_field_glo
	77
	78	SUBROUTINE allocate_field(field, field_type, data_type, dim3, dim4, name, ondevice)
	79	USE domain_mod
	80	USE omp_para
	81	TYPE(t_field), POINTER :: field(:)
	82	INTEGER, INTENT(IN) :: field_type
	83	INTEGER, INTENT(IN) :: data_type
	84	INTEGER, OPTIONAL :: dim3,dim4
[350]	85	CHARACTER(*), OPTIONAL :: name
[953]	86	LOGICAL, INTENT(IN), OPTIONAL :: ondevice
[1055]	87	INTEGER :: ind
	88	!$OMP BARRIER
	89	!$OMP MASTER
	90	ALLOCATE(field(ndomain))
	91	!$OMP END MASTER
	92	!$OMP BARRIER
	93
	94	DO ind=1,ndomain
	95	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
	96	CALL allocate_field_(domain(ind), field(ind), field_type, data_type, dim3, dim4, name, ondevice)
	97	END DO
	98	!$OMP BARRIER
	99
	100	END SUBROUTINE allocate_field
	101
	102	SUBROUTINE allocate_fields(nfield,field,field_type,data_type,dim3,dim4,name, ondevice)
	103	USE domain_mod
	104	USE omp_para
	105	INTEGER, INTENT(IN) :: nfield
	106	TYPE(t_field), POINTER :: field(:,:)
	107	INTEGER, INTENT(IN) :: field_type
	108	INTEGER, INTENT(IN) :: data_type
	109	INTEGER, OPTIONAL :: dim3,dim4
	110	CHARACTER(*), OPTIONAL :: name
	111	LOGICAL, INTENT(IN), OPTIONAL :: ondevice
	112	INTEGER :: i, ind
	113	!$OMP BARRIER
	114	!$OMP MASTER
[350]	115	ALLOCATE(field(ndomain,nfield))
[1055]	116	!$OMP END MASTER
	117	!$OMP BARRIER
	118	DO ind=1,ndomain
	119	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
	120	DO i=1,nfield
	121	CALL allocate_field_(domain(ind), field(ind,i),field_type, data_type, dim3, dim4, name, ondevice)
	122	END DO
[350]	123	END DO
[1055]	124	!$OMP BARRIER
	125
[350]	126	END SUBROUTINE allocate_fields
	127
[1055]	128	SUBROUTINE allocate_field_(dom, field, field_type, data_type, dim3, dim4, name, ondevice)
	129	USE domain_mod
	130	USE omp_para
	131	TYPE(t_domain) :: dom
	132	TYPE(t_field) :: field
	133	INTEGER, INTENT(IN) :: field_type
	134	INTEGER, INTENT(IN) :: data_type
	135	INTEGER, OPTIONAL :: dim3,dim4
[350]	136	CHARACTER(*), OPTIONAL :: name
[953]	137	LOGICAL, INTENT(IN), OPTIONAL :: ondevice
[1055]	138
[1053]	139	INTEGER :: ij_size
[350]	140
[1055]	141	IF(PRESENT(name)) THEN
	142	field%name = name
	143	ELSE
	144	field%name = '(undefined)'
	145	END IF
[186]	146
[1055]	147	IF (PRESENT(dim4)) THEN
	148	field%ndim=4
	149	field%dim4=dim4
	150	field%dim3=dim3
	151	ELSE IF (PRESENT(dim3)) THEN
	152	field%ndim=3
	153	field%dim3=dim3
	154	field%dim4=1
	155	ELSE
	156	field%ndim=2
	157	field%dim3=1
	158	field%dim4=1
	159	ENDIF
[138]	160
[953]	161
[1055]	162	field%data_type=data_type
	163	field%field_type=field_type
[953]	164
[1055]	165	IF (field_type==field_T) THEN
	166	ij_size=dom%iim*dom%jjm
	167	ELSE IF (field_type==field_U) THEN
	168	ij_size=3dom%iimdom%jjm
	169	ELSE IF (field_type==field_Z) THEN
	170	ij_size=2dom%iimdom%jjm
	171	ENDIF
[953]	172
[1055]	173	IF (data_type==type_integer) ALLOCATE(field%ival4d(ij_size, field%dim3, field%dim4))
	174	IF (data_type==type_real) ALLOCATE(field%rval4d(ij_size, field%dim3, field%dim4))
	175	IF (data_type==type_logical) ALLOCATE(field%lval4d(ij_size, field%dim3, field%dim4))
[953]	176
[1055]	177	IF (field%ndim==3) THEN
	178	IF (data_type==type_integer) field%ival3d => field%ival4d(:,:,1)
	179	IF (data_type==type_real) field%rval3d => field%rval4d(:,:,1)
	180	IF (data_type==type_logical) field%lval3d => field%lval4d(:,:,1)
[953]	181
[1055]	182	ELSE IF (field%ndim==2) THEN
	183	IF (data_type==type_integer) field%ival2d => field%ival4d(:,1,1)
	184	IF (data_type==type_real) field%rval2d => field%rval4d(:,1,1)
	185	IF (data_type==type_logical) field%lval2d => field%lval4d(:,1,1)
[26]	186
[1055]	187	ENDIF
	188
	189	field%ondevice = .FALSE.
	190	IF (PRESENT(ondevice)) THEN
	191	IF (ondevice) CALL create_device_field(field)
	192	END IF
	193
	194	END SUBROUTINE allocate_field_
	195
	196	!==================================== deallocate_field ===================================
	197
	198	SUBROUTINE deallocate_field_glo(field)
	199	USE domain_mod
[26]	200	TYPE(t_field),POINTER :: field(:)
	201	INTEGER :: ind
	202	DO ind=1,ndomain_glo
[1055]	203	CALL deallocate_field_(field(ind))
	204	END DO
	205	DEALLOCATE(field)
	206	END SUBROUTINE deallocate_field_glo
[953]	207
[26]	208	SUBROUTINE deallocate_field(field)
[350]	209	USE domain_mod
	210	USE omp_para
	211	TYPE(t_field),POINTER :: field(:)
[1055]	212	INTEGER :: ind
[350]	213	!$OMP BARRIER
[1055]	214	DO ind=1,ndomain
	215	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
	216	CALL deallocate_field_(field(ind))
	217	END DO
[350]	218	!$OMP BARRIER
	219	!$OMP MASTER
	220	DEALLOCATE(field)
	221	!$OMP END MASTER
	222	!$OMP BARRIER
	223	END SUBROUTINE deallocate_field
[1055]	224
[350]	225	SUBROUTINE deallocate_fields(field)
	226	USE domain_mod
	227	USE omp_para
	228	TYPE(t_field),POINTER :: field(:,:)
[1055]	229	INTEGER :: i, ind
[350]	230	!$OMP BARRIER
[1055]	231	DO ind=1,ndomain
	232	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
	233	DO i=1,SIZE(field,2)
	234	CALL deallocate_field_(field(ind,i))
	235	END DO
[350]	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_(field)
[1055]	245	USE domain_mod
	246	USE omp_para
	247	TYPE(t_field) :: field
[26]	248	INTEGER :: data_type
[1055]	249	data_type=field%data_type
	250	IF (data_type==type_real) THEN
	251	IF (field%ondevice) THEN
	252	!$acc exit data delete(field%rval4d(:,:,:))
	253	CONTINUE
[1053]	254	END IF
[1055]	255	DEALLOCATE(field%rval4d)
	256	END IF
	257	IF (data_type==type_integer) THEN
	258	IF (field%ondevice) THEN
	259	!$acc exit data delete(field%ival4d(:,:,:))
	260	CONTINUE
[1053]	261	END IF
[1055]	262	DEALLOCATE(field%ival4d)
	263	END IF
	264	IF (data_type==type_logical) THEN
	265	IF (field%ondevice) THEN
	266	!$acc exit data delete(field%lval4d(:,:,:))
	267	CONTINUE
[1053]	268	END IF
[1055]	269	DEALLOCATE(field%lval4d)
	270	END IF
[953]	271
[350]	272	END SUBROUTINE deallocate_field_
[26]	273
[1055]	274	!====================================== getval ===================================
[26]	275
[12]	276	SUBROUTINE getval_r2d(field_pt,field)
[1055]	277	REAL(rstd), POINTER, INTENT(INOUT) :: field_pt(:)
[12]	278	TYPE(t_field),INTENT(IN) :: field
[1055]	279
[138]	280	IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
[1055]	281	PRINT *, 'getval_r2d : bad pointer assignment with ' // TRIM(field%name)
[138]	282	STOP
	283	END IF
[12]	284	field_pt=>field%rval2d
[1055]	285	END SUBROUTINE getval_r2d
[12]	286
	287	SUBROUTINE getval_r3d(field_pt,field)
[1055]	288	REAL(rstd), POINTER, INTENT(INOUT) :: field_pt(:,:)
[12]	289	TYPE(t_field),INTENT(IN) :: field
[1055]	290
[138]	291	IF (field%ndim/=3 .OR. field%data_type/=type_real) THEN
[1055]	292	PRINT *, 'getval_r3d : bad pointer assignment with ' // TRIM(field%name)
[138]	293	STOP
	294	END IF
[12]	295	field_pt=>field%rval3d
[1055]	296	END SUBROUTINE getval_r3d
[12]	297
	298	SUBROUTINE getval_r4d(field_pt,field)
[1055]	299	REAL(rstd), POINTER, INTENT(INOUT) :: field_pt(:,:,:)
[12]	300	TYPE(t_field),INTENT(IN) :: field
[1055]	301
[138]	302	IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
[1055]	303	PRINT *, 'getval_r4d : bad pointer assignment with ' // TRIM(field%name)
[138]	304	STOP
	305	END IF
[12]	306	field_pt=>field%rval4d
[1055]	307	END SUBROUTINE getval_r4d
[12]	308
	309	SUBROUTINE getval_i2d(field_pt,field)
[1055]	310	INTEGER, POINTER, INTENT(INOUT) :: field_pt(:)
[12]	311	TYPE(t_field),INTENT(IN) :: field
[1055]	312
	313	IF (field%ndim/=2 .OR. field%data_type/=type_integer) THEN
	314	PRINT *, 'getval_i2d : bad pointer assignment with ' // TRIM(field%name)
	315	STOP
	316	END IF
[12]	317	field_pt=>field%ival2d
[1055]	318	END SUBROUTINE getval_i2d
[12]	319
	320	SUBROUTINE getval_i3d(field_pt,field)
[1055]	321	INTEGER, POINTER, INTENT(INOUT) :: field_pt(:,:)
[12]	322	TYPE(t_field),INTENT(IN) :: field
[1055]	323
	324	IF (field%ndim/=3 .OR. field%data_type/=type_integer) THEN
	325	PRINT *, 'getval_i3d : bad pointer assignment with ' // TRIM(field%name)
	326	STOP
	327	END IF
[12]	328	field_pt=>field%ival3d
[1055]	329	END SUBROUTINE getval_i3d
[12]	330
	331	SUBROUTINE getval_i4d(field_pt,field)
[1055]	332	INTEGER, POINTER, INTENT(INOUT) :: field_pt(:,:,:)
[12]	333	TYPE(t_field),INTENT(IN) :: field
[1055]	334
	335	IF (field%ndim/=4 .OR. field%data_type/=type_integer) THEN
	336	PRINT *, 'getval_i4d : bad pointer assignment with ' // TRIM(field%name)
	337	STOP
	338	END IF
[12]	339	field_pt=>field%ival4d
[1055]	340	END SUBROUTINE getval_i4d
[12]	341
	342	SUBROUTINE getval_l2d(field_pt,field)
[1055]	343	LOGICAL, POINTER, INTENT(INOUT) :: field_pt(:)
[12]	344	TYPE(t_field),INTENT(IN) :: field
[1055]	345
	346	IF (field%ndim/=2 .OR. field%data_type/=type_logical) THEN
	347	PRINT *, 'getval_l2d : bad pointer assignment with ' // TRIM(field%name)
	348	STOP
	349	END IF
[12]	350	field_pt=>field%lval2d
[1055]	351	END SUBROUTINE getval_l2d
[12]	352
	353	SUBROUTINE getval_l3d(field_pt,field)
[1055]	354	LOGICAL, POINTER, INTENT(INOUT) :: field_pt(:,:)
[12]	355	TYPE(t_field),INTENT(IN) :: field
[1055]	356
	357	IF (field%ndim/=3 .OR. field%data_type/=type_logical) THEN
	358	PRINT *, 'getval_l3d : bad pointer assignment with ' // TRIM(field%name)
	359	STOP
	360	END IF
[12]	361	field_pt=>field%lval3d
[1055]	362	END SUBROUTINE getval_l3d
[12]	363
	364	SUBROUTINE getval_l4d(field_pt,field)
[1055]	365	LOGICAL, POINTER, INTENT(INOUT) :: field_pt(:,:,:)
[12]	366	TYPE(t_field),INTENT(IN) :: field
[1055]	367
	368	IF (field%ndim/=4 .OR. field%data_type/=type_logical) THEN
	369	PRINT *, 'getval_l4d : bad pointer assignment with ' // TRIM(field%name)
	370	STOP
	371	END IF
[12]	372	field_pt=>field%lval4d
[1055]	373	END SUBROUTINE getval_l4d
[12]	374
[1055]	375	!===================== Data transfer between host (CPU) and device (GPU) =========================
[953]	376
	377	SUBROUTINE update_device_field(field)
[1055]	378	USE domain_mod
	379	USE omp_para
[953]	380	TYPE(t_field) :: field(:)
	381	INTEGER :: ind
	382
	383	DO ind=1,ndomain
[1055]	384	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
[953]	385
[1055]	386	IF (.NOT. field(ind)%ondevice) CALL create_device_field(field(ind))
	387	IF (field(ind)%data_type==type_real) THEN
	388	!$acc update device(field(ind)%rval4d(:,:,:)) async
	389	CONTINUE
	390	END IF
	391	IF (field(ind)%data_type==type_integer) THEN
	392	!$acc update device(field(ind)%ival4d(:,:,:)) async
	393	CONTINUE
	394	END IF
	395	IF (field(ind)%data_type==type_logical) THEN
	396	!$acc update device(field(ind)%lval4d(:,:,:)) async
	397	CONTINUE
	398	END IF
[953]	399
[1055]	400	ENDDO
	401	!$OMP BARRIER
	402	END SUBROUTINE update_device_field
[953]	403
	404	SUBROUTINE update_host_field(field)
[1055]	405	USE domain_mod
	406	USE omp_para
[953]	407	TYPE(t_field) :: field(:)
	408	INTEGER :: ind
	409
	410	DO ind=1,ndomain
[1055]	411	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
[953]	412
[1055]	413	IF (field(ind)%ondevice) THEN
	414	IF (field(ind)%data_type==type_real) THEN
	415	!$acc update host(field(ind)%rval4d(:,:,:)) async
	416	CONTINUE
	417	END IF
	418	IF (field(ind)%data_type==type_integer) THEN
	419	!$acc update host(field(ind)%ival4d(:,:,:)) async
	420	CONTINUE
	421	END IF
	422	IF (field(ind)%data_type==type_logical) THEN
	423	!$acc update host(field(ind)%lval4d(:,:,:)) async
	424	CONTINUE
	425	END IF
[963]	426
[1055]	427	END IF
	428	ENDDO
	429	!$acc wait
	430	!$OMP BARRIER
	431	END SUBROUTINE update_host_field
[953]	432
[1055]	433	SUBROUTINE create_device_field(field)
[953]	434	TYPE(t_field) :: field
	435
	436	IF (field%ondevice) THEN
	437	PRINT *, "Field is already on device !"
	438	STOP 1
	439	END IF
[1055]	440	IF (field%data_type==type_real) THEN
	441	!$acc enter data create(field%rval4d(:,:,:)) async
	442	END IF
	443	IF (field%data_type==type_integer) THEN
	444	!$acc enter data create(field%ival4d(:,:,:)) async
	445	END IF
	446	IF (field%data_type==type_logical) THEN
	447	!$acc enter data create(field%lval4d(:,:,:)) async
	448	END IF
[953]	449
	450	field%ondevice = .TRUE.
	451	END SUBROUTINE create_device_field
[1055]	452
	453	END MODULE field_mod

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

Context Navigation

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

Download in other formats: