Context Navigation

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

Last change on this file since 1025 was 963, checked in by adurocher, 5 years ago
Merge 'mpi_rewrite' into trunk
File size: 22.0 KB

Rev	Line
[12]	1	MODULE field_mod
	2	USE genmod
[350]	3	IMPLICIT NONE
[12]	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
[138]	14	CHARACTER(30) :: name
[963]	15	REAL(rstd),POINTER, CONTIGUOUS :: rval2d(:) => null()
	16	REAL(rstd),POINTER, CONTIGUOUS :: rval3d(:,:) => null()
	17	REAL(rstd),POINTER, CONTIGUOUS :: rval4d(:,:,:) => null()
[12]	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
[26]	30	INTEGER :: dim3
	31	INTEGER :: dim4
[953]	32
	33	LOGICAL :: ondevice !< flag if field is allocated on device as well
[12]	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
[350]	48	PRIVATE :: allocate_field_
[12]	49
	50	CONTAINS
	51
[953]	52	SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2,name,ondevice)
[12]	53	USE domain_mod
[295]	54	USE omp_para
[12]	55	TYPE(t_field),POINTER :: field(:)
	56	INTEGER,INTENT(IN) :: field_type
	57	INTEGER,INTENT(IN) :: data_type
	58	INTEGER,OPTIONAL :: dim1,dim2
[138]	59	CHARACTER(*), OPTIONAL :: name
[953]	60	LOGICAL, INTENT(IN), OPTIONAL :: ondevice
[186]	61	!$OMP BARRIER
	62	!$OMP MASTER
[953]	63	ALLOCATE(field(ndomain))
[186]	64	!$OMP END MASTER
	65	!$OMP BARRIER
[953]	66
	67	CALL allocate_field_(field,field_type,data_type,dim1,dim2,name,ondevice)
	68
[350]	69	END SUBROUTINE allocate_field
[12]	70
[953]	71	SUBROUTINE allocate_fields(nfield,field,field_type,data_type,dim1,dim2,name, ondevice)
[350]	72	USE domain_mod
	73	USE omp_para
	74	INTEGER,INTENT(IN) :: nfield
	75	TYPE(t_field),POINTER :: field(:,:)
	76	INTEGER,INTENT(IN) :: field_type
	77	INTEGER,INTENT(IN) :: data_type
	78	INTEGER,OPTIONAL :: dim1,dim2
	79	CHARACTER(*), OPTIONAL :: name
[953]	80	LOGICAL, INTENT(IN), OPTIONAL :: ondevice
[350]	81	INTEGER :: i
	82	!$OMP BARRIER
	83	!$OMP MASTER
	84	ALLOCATE(field(ndomain,nfield))
	85	!$OMP END MASTER
	86	!$OMP BARRIER
	87	DO i=1,nfield
[953]	88	CALL allocate_field_(field(:,i),field_type,data_type,dim1,dim2,name,ondevice)
[350]	89	END DO
	90	END SUBROUTINE allocate_fields
	91
[953]	92	SUBROUTINE allocate_field_(field,field_type,data_type,dim1,dim2,name,ondevice)
[350]	93	USE domain_mod
	94	USE omp_para
	95	IMPLICIT NONE
	96	TYPE(t_field) :: field(:)
	97	INTEGER,INTENT(IN) :: field_type
	98	INTEGER,INTENT(IN) :: data_type
	99	INTEGER,OPTIONAL :: dim1,dim2
	100	CHARACTER(*), OPTIONAL :: name
[953]	101	LOGICAL, INTENT(IN), OPTIONAL :: ondevice
[350]	102	INTEGER :: ind
	103	INTEGER :: ii_size,jj_size
	104
[12]	105	DO ind=1,ndomain
[295]	106	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
[186]	107
[138]	108	IF(PRESENT(name)) THEN
	109	field(ind)%name = name
	110	ELSE
[159]	111	field(ind)%name = '(undefined)'
[138]	112	END IF
	113
[12]	114	IF (PRESENT(dim2)) THEN
	115	field(ind)%ndim=4
[26]	116	field(ind)%dim4=dim2
[29]	117	field(ind)%dim3=dim1
[12]	118	ELSE IF (PRESENT(dim1)) THEN
	119	field(ind)%ndim=3
[26]	120	field(ind)%dim3=dim1
[12]	121	ELSE
	122	field(ind)%ndim=2
	123	ENDIF
	124
	125
	126	field(ind)%data_type=data_type
	127	field(ind)%field_type=field_type
[953]	128
[12]	129	IF (field_type==field_T) THEN
	130	jj_size=domain(ind)%jjm
	131	ELSE IF (field_type==field_U) THEN
	132	jj_size=3*domain(ind)%jjm
	133	ELSE IF (field_type==field_Z) THEN
	134	jj_size=2*domain(ind)%jjm
	135	ENDIF
	136
	137	ii_size=domain(ind)%iim
	138
	139	IF (field(ind)%ndim==4) THEN
[953]	140	IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
	141	IF (data_type==type_real) ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
	142	IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
	143
[12]	144	ELSE IF (field(ind)%ndim==3) THEN
[953]	145	IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
	146	IF (data_type==type_real) ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
	147	IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
	148
[12]	149	ELSE IF (field(ind)%ndim==2) THEN
[953]	150	IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
	151	IF (data_type==type_real) ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
	152	IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
	153
[12]	154	ENDIF
[953]	155
	156	field(ind)%ondevice = .FALSE.
	157	IF (PRESENT(ondevice)) THEN
	158	IF (ondevice) CALL create_device_field(field(ind))
	159	END IF
	160
[12]	161	ENDDO
[186]	162	!$OMP BARRIER
[12]	163
[350]	164	END SUBROUTINE allocate_field_
[26]	165
[266]	166	SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name)
[26]	167	USE domain_mod
	168	IMPLICIT NONE
	169	TYPE(t_field),POINTER :: field(:)
	170	INTEGER,INTENT(IN) :: field_type
	171	INTEGER,INTENT(IN) :: data_type
	172	INTEGER,OPTIONAL :: dim1,dim2
[266]	173	CHARACTER(*), OPTIONAL :: name
[26]	174	INTEGER :: ind
	175	INTEGER :: ii_size,jj_size
	176
[953]	177	ALLOCATE(field(ndomain_glo))
[26]	178
	179	DO ind=1,ndomain_glo
[12]	180
[26]	181	IF (PRESENT(dim2)) THEN
	182	field(ind)%ndim=4
	183	field(ind)%dim4=dim2
[29]	184	field(ind)%dim3=dim1
[26]	185	ELSE IF (PRESENT(dim1)) THEN
	186	field(ind)%ndim=3
	187	field(ind)%dim3=dim1
	188	ELSE
	189	field(ind)%ndim=2
	190	ENDIF
	191
[266]	192	IF(PRESENT(name)) THEN
	193	field(ind)%name = name
	194	ELSE
	195	field(ind)%name = '(undefined)'
	196	END IF
[26]	197
	198	field(ind)%data_type=data_type
	199	field(ind)%field_type=field_type
	200
[953]	201	field(ind)%ondevice = .FALSE.
	202
[26]	203	IF (field_type==field_T) THEN
	204	jj_size=domain_glo(ind)%jjm
	205	ELSE IF (field_type==field_U) THEN
	206	jj_size=3*domain_glo(ind)%jjm
	207	ELSE IF (field_type==field_Z) THEN
	208	jj_size=2*domain_glo(ind)%jjm
	209	ENDIF
	210
	211	ii_size=domain_glo(ind)%iim
	212
	213	IF (field(ind)%ndim==4) THEN
	214	IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
	215	IF (data_type==type_real) ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
	216	IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
	217	ELSE IF (field(ind)%ndim==3) THEN
	218	IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
	219	IF (data_type==type_real) ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
	220	IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
	221	ELSE IF (field(ind)%ndim==2) THEN
	222	IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
	223	IF (data_type==type_real) ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
	224	IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
	225	ENDIF
	226
	227	ENDDO
	228
	229	END SUBROUTINE allocate_field_glo
	230
	231	SUBROUTINE deallocate_field(field)
[350]	232	USE domain_mod
	233	USE omp_para
	234	IMPLICIT NONE
	235	TYPE(t_field),POINTER :: field(:)
	236	!$OMP BARRIER
	237	CALL deallocate_field_(field)
	238	!$OMP BARRIER
	239	!$OMP MASTER
	240	DEALLOCATE(field)
	241	!$OMP END MASTER
	242	!$OMP BARRIER
	243	END SUBROUTINE deallocate_field
	244
	245	SUBROUTINE deallocate_fields(field)
	246	USE domain_mod
	247	USE omp_para
	248	IMPLICIT NONE
	249	TYPE(t_field),POINTER :: field(:,:)
	250	INTEGER :: i
	251	!$OMP BARRIER
	252	DO i=1,SIZE(field,2)
	253	CALL deallocate_field_(field(:,i))
	254	END DO
	255	!$OMP BARRIER
	256	!$OMP MASTER
	257	DEALLOCATE(field)
	258	!$OMP END MASTER
	259	!$OMP BARRIER
	260	END SUBROUTINE deallocate_fields
	261
	262	SUBROUTINE deallocate_field_(field)
[26]	263	USE domain_mod
[295]	264	USE omp_para
[26]	265	IMPLICIT NONE
[350]	266	TYPE(t_field) :: field(:)
[26]	267	INTEGER :: data_type
	268	INTEGER :: ind
	269	DO ind=1,ndomain
[953]	270	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
[26]	271
[953]	272	data_type=field(ind)%data_type
	273
	274	IF (field(ind)%ndim==4) THEN
	275	IF (data_type==type_integer) THEN
	276	IF (field(ind)%ondevice) THEN
[963]	277	!$acc exit data delete(field(ind)%ival4d(:,:,:))
[953]	278	CONTINUE
	279	END IF
[963]	280	DEALLOCATE(field(ind)%ival4d)
[953]	281	END IF
	282
	283	IF (data_type==type_real) THEN
	284	IF (field(ind)%ondevice) THEN
[963]	285	!$acc exit data delete(field(ind)%rval4d(:,:,:))
[953]	286	CONTINUE
	287	END IF
[963]	288	DEALLOCATE(field(ind)%rval4d)
[953]	289	END IF
	290
	291	IF (data_type==type_logical) THEN
	292	IF (field(ind)%ondevice) THEN
[963]	293	!$acc exit data delete(field(ind)%lval4d(:,:,:))
[953]	294	CONTINUE
	295	END IF
[963]	296	DEALLOCATE(field(ind)%lval4d)
[953]	297	END IF
	298
	299	ELSE IF (field(ind)%ndim==3) THEN
	300	IF (data_type==type_integer) THEN
	301	IF (field(ind)%ondevice) THEN
[963]	302	!$acc exit data delete(field(ind)%ival3d(:,:))
[953]	303	CONTINUE
	304	END IF
[963]	305	DEALLOCATE(field(ind)%ival3d)
[953]	306	END IF
	307
	308	IF (data_type==type_real) THEN
	309	IF (field(ind)%ondevice) THEN
[963]	310	!$acc exit data delete(field(ind)%rval3d(:,:))
[953]	311	CONTINUE
	312	END IF
[963]	313	DEALLOCATE(field(ind)%rval3d)
[953]	314	END IF
	315
	316	IF (data_type==type_logical) THEN
	317	IF (field(ind)%ondevice) THEN
[963]	318	!$acc exit data delete(field(ind)%lval3d(:,:))
[953]	319	CONTINUE
	320	END IF
[963]	321	DEALLOCATE(field(ind)%lval3d)
[953]	322	END IF
	323
	324	ELSE IF (field(ind)%ndim==2) THEN
	325	IF (data_type==type_integer) THEN
	326	IF (field(ind)%ondevice) THEN
[963]	327	!$acc exit data delete(field(ind)%ival2d(:))
[953]	328	CONTINUE
	329	END IF
[963]	330	DEALLOCATE(field(ind)%ival2d)
[953]	331	END IF
	332
	333	IF (data_type==type_real) THEN
	334	IF (field(ind)%ondevice) THEN
[963]	335	!$acc exit data delete(field(ind)%rval2d(:))
[953]	336	CONTINUE
	337	END IF
[963]	338	DEALLOCATE(field(ind)%rval2d)
[953]	339	END IF
	340
	341	IF (data_type==type_logical) THEN
	342	IF (field(ind)%ondevice) THEN
[963]	343	!$acc exit data delete(field(ind)%lval2d(:))
[953]	344	CONTINUE
	345	END IF
[963]	346	DEALLOCATE(field(ind)%lval2d)
[953]	347	END IF
	348
	349	ENDIF
	350	ENDDO
[350]	351	END SUBROUTINE deallocate_field_
[26]	352
	353	SUBROUTINE deallocate_field_glo(field)
	354	USE domain_mod
	355	IMPLICIT NONE
	356	TYPE(t_field),POINTER :: field(:)
	357	INTEGER :: data_type
	358	INTEGER :: ind
	359
	360	DO ind=1,ndomain_glo
	361
	362	data_type=field(ind)%data_type
	363
	364	IF (field(ind)%ndim==4) THEN
	365	IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
	366	IF (data_type==type_real) DEALLOCATE(field(ind)%rval4d)
	367	IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
	368	ELSE IF (field(ind)%ndim==3) THEN
	369	IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
	370	IF (data_type==type_real) DEALLOCATE(field(ind)%rval3d)
	371	IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
	372	ELSE IF (field(ind)%ndim==2) THEN
	373	IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
	374	IF (data_type==type_real) DEALLOCATE(field(ind)%rval2d)
	375	IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
	376	ENDIF
	377
	378	ENDDO
	379	DEALLOCATE(field)
	380
	381	END SUBROUTINE deallocate_field_glo
	382
[396]	383	SUBROUTINE extract_slice(field_in, field_out, l)
	384	USE domain_mod
	385	USE omp_para
	386	IMPLICIT NONE
	387	TYPE(t_field) :: field_in(:)
	388	TYPE(t_field) :: field_out(:)
	389	INTEGER,INTENT(IN) :: l
	390
	391	INTEGER :: ind
	392	INTEGER :: data_type
	393
	394	!$OMP BARRIER
	395	DO ind=1,ndomain
	396	data_type=field_in(ind)%data_type
	397	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
	398
	399	IF (field_in(ind)%ndim==3 .AND. field_out(ind)%ndim==2) THEN
	400	IF (data_type==type_integer) field_out(ind)%ival2d=field_in(ind)%ival3d(:,l)
	401	IF (data_type==type_real) field_out(ind)%rval2d=field_in(ind)%rval3d(:,l)
	402	IF (data_type==type_logical) field_out(ind)%lval2d=field_in(ind)%lval3d(:,l)
	403	ELSE IF (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
	404	IF (data_type==type_integer) field_out(ind)%ival3d=field_in(ind)%ival4d(:,:,l)
	405	IF (data_type==type_real) field_out(ind)%rval3d=field_in(ind)%rval4d(:,:,l)
	406	IF (data_type==type_logical) field_out(ind)%lval3d=field_in(ind)%lval4d(:,:,l)
	407	ELSE
	408	PRINT *, 'extract_slice : cannot extract slice, dimension incompatible'
	409	STOP
	410	ENDIF
	411	ENDDO
	412	!$OMP BARRIER
	413	END SUBROUTINE extract_slice
	414
	415
	416	SUBROUTINE insert_slice(field_in, field_out, l)
	417	USE domain_mod
	418	USE omp_para
	419	IMPLICIT NONE
	420	TYPE(t_field) :: field_in(:)
	421	TYPE(t_field) :: field_out(:)
	422	INTEGER,INTENT(IN) :: l
	423
	424	INTEGER :: ind
	425	INTEGER :: data_type
	426
	427	!$OMP BARRIER
	428	DO ind=1,ndomain
	429	data_type=field_in(ind)%data_type
	430	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
	431
	432	IF (field_in(ind)%ndim==2 .AND. field_out(ind)%ndim==3) THEN
	433	IF (data_type==type_integer) field_out(ind)%ival3d(:,l)=field_in(ind)%ival2d(:)
	434	IF (data_type==type_real) field_out(ind)%rval3d(:,l)=field_in(ind)%rval2d(:)
	435	IF (data_type==type_logical) field_out(ind)%lval3d(:,l)=field_in(ind)%lval2d(:)
	436	ELSE IF (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
	437	IF (data_type==type_integer) field_out(ind)%ival4d(:,:,l)=field_out(ind)%ival3d(:,:)
	438	IF (data_type==type_real) field_out(ind)%rval4d(:,:,l)=field_out(ind)%rval3d(:,:)
	439	IF (data_type==type_logical) field_out(ind)%lval4d(:,:,l)=field_out(ind)%lval3d(:,:)
	440	ELSE
	441	PRINT *, 'extract_slice : cannot insert slice, dimension incompatible'
	442	STOP
	443	ENDIF
	444	ENDDO
	445	!$OMP BARRIER
	446
	447	END SUBROUTINE insert_slice
	448
[12]	449	SUBROUTINE getval_r2d(field_pt,field)
	450	IMPLICIT NONE
	451	REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
	452	TYPE(t_field),INTENT(IN) :: field
	453
[138]	454	IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
[159]	455	PRINT *, 'get_val_r2d : bad pointer assignment with ' // TRIM(field%name)
[138]	456	STOP
	457	END IF
[12]	458	field_pt=>field%rval2d
	459	END SUBROUTINE getval_r2d
	460
	461	SUBROUTINE getval_r3d(field_pt,field)
	462	IMPLICIT NONE
	463	REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:)
	464	TYPE(t_field),INTENT(IN) :: field
	465
[138]	466	IF (field%ndim/=3 .OR. field%data_type/=type_real) THEN
[159]	467	PRINT *, 'get_val_r3d : bad pointer assignment with ' // TRIM(field%name)
[138]	468	STOP
[159]	469	! CALL ABORT
[138]	470	END IF
[12]	471	field_pt=>field%rval3d
	472	END SUBROUTINE getval_r3d
	473
	474	SUBROUTINE getval_r4d(field_pt,field)
	475	IMPLICIT NONE
	476	REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
	477	TYPE(t_field),INTENT(IN) :: field
	478
[138]	479	IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
[159]	480	PRINT *, 'get_val_r4d : bad pointer assignment with ' // TRIM(field%name)
[138]	481	STOP
	482	END IF
[12]	483	field_pt=>field%rval4d
[138]	484	END SUBROUTINE getval_r4d
[12]	485
	486
	487	SUBROUTINE getval_i2d(field_pt,field)
	488	IMPLICIT NONE
	489	INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
	490	TYPE(t_field),INTENT(IN) :: field
	491
[159]	492	IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignment'
[12]	493	field_pt=>field%ival2d
	494	END SUBROUTINE getval_i2d
	495
	496	SUBROUTINE getval_i3d(field_pt,field)
	497	IMPLICIT NONE
	498	INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
	499	TYPE(t_field),INTENT(IN) :: field
	500
[159]	501	IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignment'
[12]	502	field_pt=>field%ival3d
	503	END SUBROUTINE getval_i3d
	504
	505	SUBROUTINE getval_i4d(field_pt,field)
	506	IMPLICIT NONE
	507	INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
	508	TYPE(t_field),INTENT(IN) :: field
	509
[159]	510	IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignment'
[12]	511	field_pt=>field%ival4d
	512	END SUBROUTINE getval_i4d
	513
	514	SUBROUTINE getval_l2d(field_pt,field)
	515	IMPLICIT NONE
	516	LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
	517	TYPE(t_field),INTENT(IN) :: field
	518
[159]	519	IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignment'
[12]	520	field_pt=>field%lval2d
	521	END SUBROUTINE getval_l2d
	522
	523	SUBROUTINE getval_l3d(field_pt,field)
	524	IMPLICIT NONE
	525	LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
	526	TYPE(t_field),INTENT(IN) :: field
	527
[159]	528	IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignment'
[12]	529	field_pt=>field%lval3d
	530	END SUBROUTINE getval_l3d
	531
	532	SUBROUTINE getval_l4d(field_pt,field)
	533	IMPLICIT NONE
	534	LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
	535	TYPE(t_field),INTENT(IN) :: field
	536
[159]	537	IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignment'
[12]	538	field_pt=>field%lval4d
	539	END SUBROUTINE getval_l4d
	540
[953]	541
	542	SUBROUTINE update_device_field(field)
	543	USE domain_mod
	544	USE omp_para
	545	IMPLICIT NONE
	546	TYPE(t_field) :: field(:)
	547	INTEGER :: ind
	548
	549	DO ind=1,ndomain
	550	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
	551
	552	IF (.NOT. field(ind)%ondevice) CALL create_device_field(field(ind))
	553
	554	IF (field(ind)%ndim==4) THEN
	555	IF (field(ind)%data_type==type_integer) THEN
[963]	556	!$acc update device(field(ind)%ival4d(:,:,:)) async
[953]	557	CONTINUE
	558	END IF
	559
	560	IF (field(ind)%data_type==type_real) THEN
[963]	561	!$acc update device(field(ind)%rval4d(:,:,:)) async
[953]	562	CONTINUE
	563	END IF
	564
	565	IF (field(ind)%data_type==type_logical) THEN
[963]	566	!$acc update device(field(ind)%lval4d(:,:,:)) async
[953]	567	CONTINUE
	568	END IF
	569
	570	ELSE IF (field(ind)%ndim==3) THEN
	571	IF (field(ind)%data_type==type_integer) THEN
[963]	572	!$acc update device(field(ind)%ival3d(:,:)) async
[953]	573	CONTINUE
	574	END IF
	575
	576	IF (field(ind)%data_type==type_real) THEN
[963]	577	!$acc update device(field(ind)%rval3d(:,:)) async
[953]	578	CONTINUE
	579	END IF
	580
	581	IF (field(ind)%data_type==type_logical) THEN
[963]	582	!$acc update device(field(ind)%lval3d(:,:)) async
[953]	583	CONTINUE
	584	END IF
	585
	586	ELSE IF (field(ind)%ndim==2) THEN
	587	IF (field(ind)%data_type==type_integer) THEN
[963]	588	!$acc update device(field(ind)%ival2d(:)) async
[953]	589	CONTINUE
	590	END IF
	591
	592	IF (field(ind)%data_type==type_real) THEN
[963]	593	!$acc update device(field(ind)%rval2d(:)) async
[953]	594	CONTINUE
	595	END IF
	596
	597	IF (field(ind)%data_type==type_logical) THEN
[963]	598	!$acc update device(field(ind)%lval2d(:)) async
[953]	599	CONTINUE
	600	END IF
	601	ENDIF
	602	ENDDO
	603	!$OMP BARRIER
	604	END SUBROUTINE update_device_field
	605
	606	SUBROUTINE update_host_field(field)
	607	USE domain_mod
	608	USE omp_para
	609	IMPLICIT NONE
	610	TYPE(t_field) :: field(:)
	611	INTEGER :: ind
	612
	613	DO ind=1,ndomain
	614	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
	615
	616	IF (field(ind)%ondevice) THEN
[963]	617
[953]	618	IF (field(ind)%ndim==4) THEN
	619	IF (field(ind)%data_type==type_integer) THEN
[963]	620	!$acc update host(field(ind)%ival4d(:,:,:)) async
[953]	621	CONTINUE
	622	END IF
	623
	624	IF (field(ind)%data_type==type_real) THEN
[963]	625	!$acc update host(field(ind)%rval4d(:,:,:)) async
[953]	626	CONTINUE
	627	END IF
	628
	629	IF (field(ind)%data_type==type_logical) THEN
[963]	630	!$acc update host(field(ind)%lval4d(:,:,:)) async
[953]	631	CONTINUE
	632	END IF
[963]	633
[953]	634	ELSE IF (field(ind)%ndim==3) THEN
	635	IF (field(ind)%data_type==type_integer) THEN
[963]	636	!$acc update host(field(ind)%ival3d(:,:)) async
[953]	637	CONTINUE
	638	END IF
	639
	640	IF (field(ind)%data_type==type_real) THEN
[963]	641	!$acc update host(field(ind)%rval3d(:,:)) async
[953]	642	CONTINUE
	643	END IF
	644
	645	IF (field(ind)%data_type==type_logical) THEN
[963]	646	!$acc update host(field(ind)%lval3d(:,:)) async
[953]	647	CONTINUE
	648	END IF
	649
	650	ELSE IF (field(ind)%ndim==2) THEN
	651	IF (field(ind)%data_type==type_integer) THEN
[963]	652	!$acc update host(field(ind)%ival2d(:)) async
[953]	653	CONTINUE
	654	END IF
	655
	656	IF (field(ind)%data_type==type_real) THEN
[963]	657	!$acc update host(field(ind)%rval2d(:)) async
[953]	658	CONTINUE
	659	END IF
	660
	661	IF (field(ind)%data_type==type_logical) THEN
[963]	662	!$acc update host(field(ind)%lval2d(:)) async
[953]	663	CONTINUE
	664	END IF
	665	ENDIF
	666	END IF
	667	ENDDO
[963]	668	!$acc wait
[953]	669	!$OMP BARRIER
	670	END SUBROUTINE update_host_field
	671
	672	SUBROUTINE create_device_field(field)
	673	TYPE(t_field) :: field
	674
	675	IF (field%ondevice) THEN
	676	PRINT *, "Field is already on device !"
	677	STOP 1
	678	END IF
	679	IF (field%ndim==4) THEN
	680	IF (field%data_type==type_integer) THEN
[963]	681	!$acc enter data create(field%ival4d(:,:,:)) async
[953]	682	END IF
	683
	684	IF (field%data_type==type_real) THEN
[963]	685	!$acc enter data create(field%rval4d(:,:,:)) async
[953]	686	END IF
	687
	688	IF (field%data_type==type_logical) THEN
[963]	689	!$acc enter data create(field%lval4d(:,:,:)) async
[953]	690	END IF
	691
	692	ELSE IF (field%ndim==3) THEN
	693	IF (field%data_type==type_integer) THEN
[963]	694	!$acc enter data create(field%ival3d(:,:)) async
[953]	695	END IF
	696
	697	IF (field%data_type==type_real) THEN
[963]	698	!$acc enter data create(field%rval3d(:,:)) async
[953]	699	END IF
	700
	701	IF (field%data_type==type_logical) THEN
[963]	702	!$acc enter data create(field%lval3d(:,:)) async
[953]	703	END IF
	704
	705	ELSE IF (field%ndim==2) THEN
	706	IF (field%data_type==type_integer) THEN
[963]	707	!$acc enter data create(field%ival2d(:)) async
[953]	708	END IF
	709
	710	IF (field%data_type==type_real) THEN
[963]	711	!$acc enter data create(field%rval2d(:)) async
[953]	712	END IF
	713
	714	IF (field%data_type==type_logical) THEN
[963]	715	!$acc enter data create(field%lval2d(:)) async
[953]	716	END IF
	717	ENDIF
	718	field%ondevice = .TRUE.
	719	END SUBROUTINE create_device_field
	720
[12]	721	END MODULE field_mod

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

Download in other formats: