New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

iom_mpp.f90 in utils/tools/SIREN/src – NEMO

Context Navigation

source: utils/tools/SIREN/src/iom_mpp.f90 @ 13146

Last change on this file since 13146 was 12080, checked in by jpaul, 5 years ago
update nemo trunk
File size: 32.4 KB

Rev	Line
[4213]	1	!----------------------------------------------------------------------
	2	! NEMO system team, System and Interface for oceanic RElocable Nesting
	3	!----------------------------------------------------------------------
	4	!
	5	! DESCRIPTION:
[5037]	6	!> @brief This module manage massively parallel processing Input/Output manager.
	7	!> Library to read/write mpp files.
[4213]	8	!>
	9	!> @details
	10	!> to open mpp files (only file to be used (see mpp_get_use)
	11	!> will be open):<br/>
[5037]	12	!> @code
[4213]	13	!> CALL iom_mpp_open(td_mpp)
[5037]	14	!> @endcode
[4213]	15	!> - td_mpp is a mpp structure
	16	!>
	17	!> to creates mpp files:<br/>
[5037]	18	!> @code
[4213]	19	!> CALL iom_mpp_create(td_mpp)
[5037]	20	!> @endcode
[4213]	21	!> - td_mpp is a mpp structure
	22	!>
	23	!> to write in mpp files :<br/>
[5037]	24	!> @code
[4213]	25	!> CALL iom_mpp_write_file(td_mpp)
[5037]	26	!> @endcode
[4213]	27	!> - td_mpp is a mpp structure
	28	!>
	29	!> to close mpp files:<br/>
[5037]	30	!> @code
[4213]	31	!> CALL iom_mpp_close(td_mpp)
[5037]	32	!> @endcode
[4213]	33	!>
	34	!> to read one variable in an mpp files:<br/>
[5037]	35	!> @code
	36	!> tl_var=iom_mpp_read_var( td_mpp, id_varid, [id_start, id_count] [,id_ew] )
	37	!> @endcode
	38	!> or
	39	!> @code
	40	!> tl_var=iom_mpp_read_var( td_mpp, cd_name, [id_start, id_count] [,id_ew] )
	41	!> @endcode
[4213]	42	!> - td_mpp is a mpp structure
	43	!> - id_varid is a variable id
[5037]	44	!> - cd_name is variable name or standard name
	45	!> - id_start is a integer(4) 1D array of index from which the data
	46	!> values will be read [optional]
	47	!> - id_count is a integer(4) 1D array of the number of indices selected
	48	!> along each dimension [optional]
	49	!> - id_ew East West overlap [optional]
[4213]	50	!>
[5037]	51	!> to fill variable value in mpp structure:<br/>
	52	!> @code
	53	!> CALL iom_mpp_fill_var(td_mpp, id_varid, [id_start, id_count] [,id_ew] )
	54	!> @endcode
	55	!> or<br/>
	56	!> @code
	57	!> CALL iom_mpp_fill_var(td_mpp, cd_name, [id_start, id_count] [,id_ew] )
	58	!> @endcode
	59	!> - td_mpp is mpp structure
	60	!> - id_varid is variable id
	61	!> - cd_name is variable name or standard name
	62	!> - id_start is a integer(4) 1D array of index from which the data
	63	!> values will be read [optional]
	64	!> - id_count is a integer(4) 1D array of the number of indices selected
	65	!> along each dimension [optional]
	66	!> - id_ew East West overlap [optional]
[4213]	67	!>
[5037]	68	!> to fill all variable in mpp structure:<br/>
	69	!> @code
	70	!> CALL iom_mpp_fill_var(td_mpp, [id_start, id_count] [,id_ew] )
	71	!> @endcode
	72	!> - td_mpp is mpp structure
	73	!> - id_start is a integer(4) 1D array of index from which the data
	74	!> values will be read [optional]
	75	!> - id_count is a integer(4) 1D array of the number of indices selected
	76	!> along each dimension [optional]
	77	!> - id_ew East West overlap
	78	!>
	79	!> to write files composong mpp strucutre:<br/>
	80	!> @code
	81	!> CALL iom_mpp_write_file(td_mpp)
	82	!> @endcode
	83	!>
[4213]	84	!> @author
	85	!> J.Paul
[12080]	86	!>
[5617]	87	!> @date November, 2013 - Initial Version
[5037]	88	!>
[12080]	89	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[4213]	90	!----------------------------------------------------------------------
	91	MODULE iom_mpp
[12080]	92
[4213]	93	USE netcdf ! nf90 library
[5037]	94	USE global ! global parameter
[4213]	95	USE kind ! F90 kind parameter
	96	USE fct ! basic useful function
[5037]	97	USE logger ! log file manager
[4213]	98	USE dim ! dimension manager
	99	USE att ! attribute manager
	100	USE var ! variable manager
	101	USE file ! file manager
	102	USE iom ! I/O manager
	103	USE mpp ! mpp manager
[12080]	104
[4213]	105	IMPLICIT NONE
	106	! NOTE_avoid_public_variables_if_possible
	107
	108	! function and subroutine
[5037]	109	PUBLIC :: iom_mpp_open !< open all files composing mpp structure
	110	PUBLIC :: iom_mpp_create !< creates files composing mpp structure
[4213]	111	PUBLIC :: iom_mpp_close !< close file composing mpp structure
	112	PUBLIC :: iom_mpp_read_var !< read one variable in an mpp structure
	113	PUBLIC :: iom_mpp_write_file !< write mpp structure in files
	114
[5037]	115	PRIVATE :: iom_mpp__read_var_id ! read one variable in an mpp structure, given variable id
	116	PRIVATE :: iom_mpp__read_var_name ! read one variable in an mpp structure, given variable name
	117	PRIVATE :: iom_mpp__read_var_value ! read variable value in an mpp structure
[4213]	118
[5037]	119	INTERFACE iom_mpp_read_var ! read one variable in an mpp structure
	120	MODULE PROCEDURE iom_mpp__read_var_id ! given variable id
	121	MODULE PROCEDURE iom_mpp__read_var_name ! given variable name
[4213]	122	END INTERFACE iom_mpp_read_var
	123
	124	CONTAINS
[12080]	125	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	126	SUBROUTINE iom_mpp_open(td_mpp, id_perio, id_ew)
[4213]	127	!-------------------------------------------------------------------
[5037]	128	!> @brief This subroutine open files composing mpp structure to be used.
	129	!> @details
[4213]	130	!> If try to open a file in write mode that did not exist, create it.<br/>
	131	!>
	132	!> If file already exist, get information about:
	133	!> - the number of variables
	134	!> - the number of dimensions
	135	!> - the number of global attributes
	136	!> - the ID of the unlimited dimension
	137	!> - the file format
	138	!> and finally read dimensions.
	139	!>
	140	!> @author J.Paul
[5617]	141	!> @date November, 2013 - Initial Version
[12080]	142	!> @date August, 2017
	143	!> - handle use of domain decomposition for monoproc file
	144	!>
[5037]	145	!> @param[inout] td_mpp mpp structure
[4213]	146	!-------------------------------------------------------------------
[12080]	147
[4213]	148	IMPLICIT NONE
[12080]	149
[4213]	150	! Argument
[5037]	151	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
	152	INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
	153	INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
[4213]	154
	155	! local variable
	156	CHARACTER(LEN=lc) :: cl_name
[12080]	157	INTEGER(i4) :: il_pid
	158	INTEGER(i4) :: il_impp
	159	INTEGER(i4) :: il_jmpp
	160	INTEGER(i4) :: il_lci
	161	INTEGER(i4) :: il_lcj
	162	INTEGER(i4) :: il_ldi
	163	INTEGER(i4) :: il_ldj
	164	INTEGER(i4) :: il_lei
	165	INTEGER(i4) :: il_lej
	166	LOGICAL :: ll_ctr
	167	LOGICAL :: ll_use
	168	LOGICAL :: ll_create
	169	INTEGER(i4) :: il_iind
	170	INTEGER(i4) :: il_jind
[4213]	171
	172	! loop indices
	173	INTEGER(i4) :: ji
	174	!----------------------------------------------------------------
	175	! check if mpp exist
	176	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	177
	178	CALL logger_error( " IOM MPP OPEN: domain decomposition not define "//&
	179	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	180
	181	ELSE
[5609]	182	!
	183	td_mpp%i_id=1
	184
[5037]	185	! if no processor file selected
	186	! force to open all files
	187	IF( .NOT. ANY( td_mpp%t_proc(:)%l_use ) )THEN
	188	td_mpp%t_proc(:)%l_use=.TRUE.
	189	ENDIF
[4213]	190
[5037]	191	! add suffix to mpp name
	192	td_mpp%c_name=file_add_suffix( TRIM(td_mpp%c_name), &
	193	& TRIM(td_mpp%c_type) )
[4213]	194
[5037]	195	td_mpp%t_proc(:)%c_type=TRIM(td_mpp%c_type)
[12080]	196	IF( td_mpp%i_nproc > 1 .AND. td_mpp%l_usempp )THEN
[5037]	197	DO ji=1,td_mpp%i_nproc
	198	IF( td_mpp%t_proc(ji)%l_use )THEN
[4213]	199
[5037]	200	SELECT CASE(TRIM(td_mpp%c_type))
	201	CASE('cdf')
	202	cl_name=TRIM( file_rename(td_mpp%c_name, ji-1) )
	203	CASE('dimg')
[4213]	204	cl_name=TRIM( file_rename(td_mpp%c_name, ji) )
[5037]	205	CASE DEFAULT
	206	CALL logger_fatal("IOM MPP OPEN: can not open file "//&
	207	& "of type "//TRIM(td_mpp%c_type))
	208	END SELECT
[4213]	209
[5037]	210	td_mpp%t_proc(ji)%c_name=TRIM(cl_name)
[4213]	211
[5037]	212	CALL iom_open(td_mpp%t_proc(ji))
[4213]	213
[5037]	214	ENDIF
	215	ENDDO
	216	ELSE ! td_mpp%i_nproc == 1
	217	cl_name=TRIM( file_rename(td_mpp%c_name) )
	218	td_mpp%t_proc(1)%c_name=TRIM(cl_name)
[4213]	219
[5037]	220	CALL iom_open(td_mpp%t_proc(1))
[12080]	221
	222	IF( .NOT. td_mpp%l_usempp )THEN
	223	! copy file structure of first proc, except layout decomposition
	224	! do not do it when creating output file.
	225	ll_create=( ALL(td_mpp%t_proc(:)%l_wrt) .AND. &
	226	& ALL(td_mpp%t_proc(:)%l_use) )
	227	IF( .NOT. ll_create )THEN
	228	DO ji=2,td_mpp%i_nproc
	229	IF( td_mpp%t_proc(ji)%l_use )THEN
	230	il_pid = td_mpp%t_proc(ji)%i_pid
	231	il_impp = td_mpp%t_proc(ji)%i_impp
	232	il_jmpp = td_mpp%t_proc(ji)%i_jmpp
	233	il_lci = td_mpp%t_proc(ji)%i_lci
	234	il_lcj = td_mpp%t_proc(ji)%i_lcj
	235	il_ldi = td_mpp%t_proc(ji)%i_ldi
	236	il_ldj = td_mpp%t_proc(ji)%i_ldj
	237	il_lei = td_mpp%t_proc(ji)%i_lei
	238	il_lej = td_mpp%t_proc(ji)%i_lej
	239	ll_ctr = td_mpp%t_proc(ji)%l_ctr
	240	ll_use = td_mpp%t_proc(ji)%l_use
	241	il_iind = td_mpp%t_proc(ji)%i_iind
	242	il_jind = td_mpp%t_proc(ji)%i_jind
	243
	244	td_mpp%t_proc(ji)=file_copy(td_mpp%t_proc(1))
	245	td_mpp%t_proc(ji)%i_id=td_mpp%t_proc(1)%i_id
	246	td_mpp%t_proc(ji)%l_def=.FALSE.
	247
	248	td_mpp%t_proc(ji)%i_pid = il_pid
	249	td_mpp%t_proc(ji)%i_impp = il_impp
	250	td_mpp%t_proc(ji)%i_jmpp = il_jmpp
	251	td_mpp%t_proc(ji)%i_lci = il_lci
	252	td_mpp%t_proc(ji)%i_lcj = il_lcj
	253	td_mpp%t_proc(ji)%i_ldi = il_ldi
	254	td_mpp%t_proc(ji)%i_ldj = il_ldj
	255	td_mpp%t_proc(ji)%i_lei = il_lei
	256	td_mpp%t_proc(ji)%i_lej = il_lej
	257	td_mpp%t_proc(ji)%l_ctr = ll_ctr
	258	td_mpp%t_proc(ji)%l_use = ll_use
	259	td_mpp%t_proc(ji)%i_iind = il_iind
	260	td_mpp%t_proc(ji)%i_jind = il_jind
	261	ENDIF
	262	ENDDO
	263	ELSE
	264	! keep file id
	265	DO ji=2,td_mpp%i_nproc
	266	IF( td_mpp%t_proc(ji)%l_use )THEN
	267	td_mpp%t_proc(ji)%i_id=td_mpp%t_proc(1)%i_id
	268	td_mpp%t_proc(ji)%l_def=.FALSE.
	269	ENDIF
	270	ENDDO
	271	ENDIF
	272	ENDIF
	273
[5037]	274	ENDIF
[4213]	275
[5037]	276	IF( PRESENT(id_ew) )THEN
	277	td_mpp%i_ew=id_ew
	278	! add east west overlap to each variable
	279	DO ji=1,td_mpp%i_nproc
	280	WHERE(td_mpp%t_proc(ji)%t_var(:)%t_dim(1)%l_use)
	281	td_mpp%t_proc(ji)%t_var(:)%i_ew=td_mpp%i_ew
	282	ENDWHERE
	283	ENDDO
	284	ENDIF
[4213]	285
[5037]	286	IF( PRESENT(id_perio) )THEN
	287	td_mpp%i_perio=id_perio
	288	ENDIF
[4213]	289
	290	ENDIF
	291
	292	END SUBROUTINE iom_mpp_open
[12080]	293	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	294	SUBROUTINE iom_mpp_create(td_mpp)
[4213]	295	!-------------------------------------------------------------------
	296	!> @brief This subroutine create files, composing mpp structure to be used,
[5037]	297	!> in write mode.
[4213]	298	!>
	299	!> @author J.Paul
[5617]	300	!> @date November, 2013 - Initial Version
[12080]	301	!>
[5037]	302	!> @param[inout] td_mpp mpp structure
[4213]	303	!-------------------------------------------------------------------
[12080]	304
[4213]	305	IMPLICIT NONE
[12080]	306
[4213]	307	! Argument
	308	TYPE(TMPP), INTENT(INOUT) :: td_mpp
	309	!----------------------------------------------------------------
	310	! check if mpp exist
	311	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	312
	313	CALL logger_error( " IOM MPP CREATE: domain decomposition not define "//&
	314	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	315
	316	ELSE
	317	! forced to open in write mode
	318	td_mpp%t_proc(:)%l_wrt=.TRUE.
	319	td_mpp%t_proc(:)%l_use=.TRUE.
	320	CALL iom_mpp_open(td_mpp)
	321	ENDIF
	322
	323	END SUBROUTINE iom_mpp_create
[12080]	324	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	325	SUBROUTINE iom_mpp_close(td_mpp)
[4213]	326	!-------------------------------------------------------------------
	327	!> @brief This subroutine close files composing mpp structure.
	328	!>
	329	!> @author J.Paul
[5617]	330	!> @date November, 2013 - Initial Version
[12080]	331	!>
[5037]	332	!> @param[in] td_mpp mpp structure
[4213]	333	!-------------------------------------------------------------------
[12080]	334
[4213]	335	IMPLICIT NONE
[12080]	336
[4213]	337	! Argument
	338	TYPE(TMPP), INTENT(INOUT) :: td_mpp
	339
	340	! loop indices
	341	INTEGER(i4) :: ji
	342	!----------------------------------------------------------------
	343	! check if mpp exist
	344	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	345
	346	CALL logger_error( " IOM MPP CLOSE: domain decomposition not define "//&
	347	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	348
	349	ELSE
[5609]	350	!
	351	td_mpp%i_id=0
	352
[12080]	353	IF( td_mpp%l_usempp )THEN
	354	DO ji=1,td_mpp%i_nproc
	355	IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN
	356	CALL iom_close(td_mpp%t_proc(ji))
	357	ENDIF
	358	ENDDO
	359	ELSE
	360	IF( td_mpp%t_proc(1)%i_id /= 0 )THEN
	361	CALL iom_close(td_mpp%t_proc(1))
	362	td_mpp%t_proc(:)%i_id=0
[4213]	363	ENDIF
[12080]	364	ENDIF
[5037]	365	td_mpp%t_proc(:)%l_use=.FALSE.
[12080]	366
[4213]	367	ENDIF
	368
	369	END SUBROUTINE iom_mpp_close
[12080]	370	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	371	FUNCTION iom_mpp__read_var_id(td_mpp, id_varid, id_start, id_count) &
	372	& RESULT (tf_var)
[4213]	373	!-------------------------------------------------------------------
	374	!> @brief This function read variable value in opened mpp files,
[5037]	375	!> given variable id.
[4213]	376	!>
	377	!> @details
[5037]	378	!> Optionally start indices and number of point to be read could be specify.
	379	!> as well as East West ovelap of the global domain.
[4213]	380	!>
	381	!> @author J.Paul
[5617]	382	!> @date November, 2013 - Initial Version
[5037]	383	!> @date October, 2014
	384	!> - use start and count array instead of domain structure.
	385	!>
	386	!> @param[in] td_mpp mpp structure
	387	!> @param[in] id_varid variable id
	388	!> @param[in] id_start index in the variable from which the data values
	389	!> will be read
	390	!> @param[in] id_count number of indices selected along each dimension
[4213]	391	!> @return variable structure
	392	!-------------------------------------------------------------------
[12080]	393
[4213]	394	IMPLICIT NONE
[12080]	395
[4213]	396	! Argument
[5037]	397	TYPE(TMPP), INTENT(IN) :: td_mpp
	398	INTEGER(i4), INTENT(IN) :: id_varid
	399	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
	400	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
[4213]	401
[12080]	402	! function
	403	TYPE(TVAR) :: tf_var
	404
[4213]	405	! local variable
	406	INTEGER(i4), DIMENSION(1) :: il_ind
	407	!----------------------------------------------------------------
	408	! check if mpp exist
	409	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	410
	411	CALL logger_error( " IOM MPP READ VAR: domain decomposition not define "//&
	412	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	413
[5609]	414	ELSEIF( td_mpp%i_id == 0 )THEN
	415
	416	CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//&
	417	& " can not read variable in "//TRIM(td_mpp%c_name))
	418
[4213]	419	ELSE
	420
[5609]	421
[4213]	422	IF( ANY(td_mpp%t_proc(:)%i_id /= 0) )THEN
	423	! look for variable id
	424	il_ind(:)=MINLOC( td_mpp%t_proc(1)%t_var(:)%i_id, &
	425	& mask=(td_mpp%t_proc(1)%t_var(:)%i_id==id_varid))
	426	IF( il_ind(1) /= 0 )THEN
	427
[12080]	428	tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_ind(1)))
[4213]	429
	430	!!! read variable value
[12080]	431	CALL iom_mpp__read_var_value(td_mpp, tf_var, id_start, id_count)
[4213]	432
	433	ELSE
	434	CALL logger_error( &
	435	& " IOM MPP READ VAR: there is no variable with id "//&
	436	& TRIM(fct_str(id_varid))//" in processor/file "//&
	437	& TRIM(td_mpp%t_proc(1)%c_name))
	438	ENDIF
	439	ELSE
	440	CALL logger_error(" IOM MPP READ VAR: can't read variable, mpp "//&
	441	& TRIM(td_mpp%c_name)//" not opened")
	442	ENDIF
	443
	444	ENDIF
	445
	446	END FUNCTION iom_mpp__read_var_id
[12080]	447	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	448	FUNCTION iom_mpp__read_var_name(td_mpp, cd_name, id_start, id_count) &
	449	& RESULT (tf_var)
[4213]	450	!-------------------------------------------------------------------
	451	!> @brief This function read variable value in opened mpp files,
[5037]	452	!> given variable name or standard name.
	453	!>
[4213]	454	!> @details
[5037]	455	!> Optionally start indices and number of point to be read could be specify.
	456	!> as well as East West ovelap of the global domain.
	457	!>
[4213]	458	!> look first for variable name. If it doesn't
	459	!> exist in file, look for variable standard name.<br/>
	460	!> If variable name is not present, check variable standard name.<br/>
[12080]	461	!>
[4213]	462	!> @author J.Paul
[5617]	463	!> @date November, 2013 - Initial Version
[5037]	464	!> @date October, 2014
	465	!> - use start and count array instead of domain structure.
[12080]	466	!>
[5037]	467	!> @param[in] td_mpp mpp structure
	468	!> @param[in] cd_name variable name
	469	!> @param[in] id_start index in the variable from which the data values
	470	!> will be read
	471	!> @param[in] id_count number of indices selected along each dimension
[4213]	472	!> @return variable structure
	473	!-------------------------------------------------------------------
[12080]	474
[4213]	475	IMPLICIT NONE
[12080]	476
[4213]	477	! Argument
[5037]	478	TYPE(TMPP), INTENT(IN) :: td_mpp
	479	CHARACTER(LEN=*), INTENT(IN) :: cd_name
	480	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
[12080]	481	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
[4213]	482
[12080]	483	! function
	484	TYPE(TVAR) :: tf_var
	485
[4213]	486	! local variable
[5037]	487	INTEGER(i4) :: il_ind
[4213]	488	!----------------------------------------------------------------
	489	! check if mpp exist
	490	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	491
	492	CALL logger_error( " IOM MPP READ VAR: domain decomposition not define "//&
	493	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	494
[5609]	495	ELSEIF( td_mpp%i_id == 0 )THEN
	496
	497	CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//&
	498	& " can not read variable in "//TRIM(td_mpp%c_name))
[12080]	499
[4213]	500	ELSE
	501
[5037]	502	il_ind=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name)
	503	IF( il_ind /= 0 )THEN
[4213]	504
[12080]	505	tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_ind))
[4213]	506
	507	!!! read variable value
[12080]	508	CALL iom_mpp__read_var_value( td_mpp, tf_var, id_start, id_count)
[4213]	509
	510	ELSE
	511
[6393]	512	CALL logger_fatal( &
[4213]	513	& " IOM MPP READ VAR: there is no variable with "//&
[5609]	514	& "name or standard name "//TRIM(cd_name)//&
[4213]	515	& " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name))
	516	ENDIF
	517
	518	ENDIF
	519
	520	END FUNCTION iom_mpp__read_var_name
[12080]	521	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	522	SUBROUTINE iom_mpp__read_var_value(td_mpp, td_var, id_start, id_count)
[4213]	523	!-------------------------------------------------------------------
	524	!> @brief This subroutine read variable value
	525	!> in an mpp structure.
	526	!>
	527	!> @details
[5037]	528	!> Optionally start indices and number of point to be read could be specify.
	529	!> as well as East West ovelap of the global domain.
[12080]	530	!>
[4213]	531	!> @author J.Paul
[5617]	532	!> @date November, 2013 - Initial Version
[5037]	533	!> @date October, 2014
	534	!> - use start and count array instead of domain structure.
	535	!>
	536	!> @param[in] td_mpp mpp structure
	537	!> @param[inout] td_var variable structure
	538	!> @param[in] id_start index in the variable from which the data values
	539	!> will be read
	540	!> @param[in] id_count number of indices selected along each dimension
[4213]	541	!-------------------------------------------------------------------
[12080]	542
[4213]	543	IMPLICIT NONE
[12080]	544
[4213]	545	! Argument
[12080]	546	TYPE(TMPP) , INTENT(IN ) :: td_mpp
	547	TYPE(TVAR) , INTENT(INOUT) :: td_var
	548	INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_start
	549	INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_count
[4213]	550
	551	! local variable
	552	INTEGER(i4) :: il_status
	553	INTEGER(i4), DIMENSION(4) :: il_ind
	554	INTEGER(i4) :: il_i1p
	555	INTEGER(i4) :: il_i2p
	556	INTEGER(i4) :: il_j1p
	557	INTEGER(i4) :: il_j2p
[5037]	558	INTEGER(i4) :: il_i1
	559	INTEGER(i4) :: il_i2
	560	INTEGER(i4) :: il_j1
	561	INTEGER(i4) :: il_j2
[4213]	562
[5037]	563	INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
	564	INTEGER(i4), DIMENSION(ip_maxdim) :: il_end
	565	INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
	566
	567	INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
	568	INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt
	569
	570	TYPE(TATT) :: tl_att
[4213]	571	TYPE(TVAR) :: tl_var
	572
	573	! loop indices
	574	INTEGER(i4) :: jk
	575	!----------------------------------------------------------------
	576
[5037]	577	il_start(:)=1
	578	IF( PRESENT(id_start) ) il_start(:)=id_start(:)
[4213]	579
[5037]	580	il_count(:)=td_mpp%t_dim(:)%i_len
	581	IF( PRESENT(id_count) ) il_count(:)=id_count(:)
[4213]	582
[5609]	583	CALL logger_debug("IOM MPP READ VAR VALUE: start "//&
	584	& TRIM(fct_str(il_start(jp_I)))//","//&
	585	& TRIM(fct_str(il_start(jp_J)))//","//&
	586	& TRIM(fct_str(il_start(jp_K)))//","//&
	587	& TRIM(fct_str(il_start(jp_L))) )
	588	CALL logger_debug("IOM MPP READ VAR VALUE: count "//&
	589	& TRIM(fct_str(il_count(jp_I)))//","//&
	590	& TRIM(fct_str(il_count(jp_J)))//","//&
	591	& TRIM(fct_str(il_count(jp_K)))//","//&
	592	& TRIM(fct_str(il_count(jp_L))) )
	593
[12080]	594	!IF( td_mpp%l_usempp .AND. (PRESENT(id_start) .OR. PRESENT(id_count)))THEN
	595	! CALL logger_fatal("IOM MPP READ VAR VALUE: should not use"//&
	596	! & " start or count arguments when usempp is False.")
	597	!ENDIF
	598
[5037]	599	DO jk=1,ip_maxdim
	600	IF( .NOT. td_var%t_dim(jk)%l_use )THEN
	601	il_start(jk) = 1
	602	il_count(jk) = 1
[4213]	603	ENDIF
	604
[5037]	605	il_end(jk)=il_start(jk)+il_count(jk)-1
	606	ENDDO
[4213]	607
[5037]	608	IF( ANY(il_end(:) > td_mpp%t_dim(:)%i_len) )THEN
[5609]	609	CALL logger_debug("IOM MPP READ VAR VALUE: start + count "//&
	610	& TRIM(fct_str(il_end(jp_I)))//","//&
	611	& TRIM(fct_str(il_end(jp_J)))//","//&
	612	& TRIM(fct_str(il_end(jp_K)))//","//&
	613	& TRIM(fct_str(il_end(jp_L))) )
	614	CALL logger_debug("IOM MPP READ VAR VALUE: dimension "//&
	615	& TRIM(fct_str(td_mpp%t_dim(jp_I)%i_len))//","//&
	616	& TRIM(fct_str(td_mpp%t_dim(jp_J)%i_len))//","//&
	617	& TRIM(fct_str(td_mpp%t_dim(jp_K)%i_len))//","//&
	618	& TRIM(fct_str(td_mpp%t_dim(jp_L)%i_len)) )
[5037]	619	CALL logger_fatal("IOM MPP READ VAR VALUE: start + count "//&
	620	& "exceed dimension bound.")
[4213]	621	ENDIF
	622
[5037]	623	! use domain dimension
	624	td_var%t_dim(:)%i_len=il_count(:)
[4213]	625
[5037]	626	! Allocate space to hold variable value in structure
	627	IF( ASSOCIATED(td_var%d_value) )THEN
	628	DEALLOCATE(td_var%d_value)
[4213]	629	ENDIF
	630
[5037]	631	ALLOCATE(td_var%d_value( il_count(1), &
	632	& il_count(2), &
	633	& il_count(3), &
	634	& il_count(4)),&
	635	& stat=il_status)
	636	IF(il_status /= 0 )THEN
[4213]	637
[5037]	638	CALL logger_error( &
	639	& " IOM MPP READ VAR VALUE: not enough space to put variable "//&
	640	& TRIM(td_var%c_name)//&
	641	& " in variable structure")
[4213]	642
	643	ENDIF
	644
[5037]	645	CALL logger_debug("IOM MPP READ VAR VALUE: shape ("//&
	646	& TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//&
	647	& TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//&
	648	& TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//&
	649	& TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" )
	650	! FillValue by default
	651	td_var%d_value(:,:,:,:)=td_var%d_fill
[4213]	652
	653	! read processor
	654	DO jk=1,td_mpp%i_nproc
	655	IF( td_mpp%t_proc(jk)%l_use )THEN
	656
	657	! get processor indices
	658	il_ind(:)=mpp_get_proc_index( td_mpp, jk )
	659	il_i1p = il_ind(1)
	660	il_i2p = il_ind(2)
	661	il_j1p = il_ind(3)
	662	il_j2p = il_ind(4)
[5037]	663
[4213]	664	IF( .NOT. td_var%t_dim(1)%l_use )THEN
[5037]	665	il_i1p=il_start(1) ; il_i2p=il_end(1)
[4213]	666	ENDIF
	667	IF( .NOT. td_var%t_dim(2)%l_use )THEN
[5037]	668	il_j1p=il_start(2) ; il_j2p=il_end(2)
	669	ENDIF
	670
	671	il_i1=MAX(il_i1p, il_start(1))
	672	il_i2=MIN(il_i2p, il_end(1))
[4213]	673
[5037]	674	il_j1=MAX(il_j1p, il_start(2))
	675	il_j2=MIN(il_j2p, il_end(2))
[4213]	676
	677	IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
[12080]	678	IF( td_mpp%l_usempp )THEN
	679	il_strt(:)=(/ il_i1-il_i1p+1, &
	680	& il_j1-il_j1p+1, &
	681	& 1,1 /)
	682	ELSE
	683	il_strt(:)=(/ il_i1, &
	684	& il_j1, &
	685	& 1,1 /)
	686	ENDIF
[4213]	687
[5037]	688	il_cnt(:)=(/ il_i2-il_i1+1, &
	689	& il_j2-il_j1+1, &
	690	& td_var%t_dim(3)%i_len, &
	691	& td_var%t_dim(4)%i_len /)
[4213]	692
	693	tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,&
[5037]	694	& il_strt(:), il_cnt(:) )
[4213]	695	! replace value in output variable structure
[5037]	696	td_var%d_value( il_i1 - il_start(1) + 1 : &
	697	& il_i2 - il_start(1) + 1, &
	698	& il_j1 - il_start(2) + 1 : &
	699	& il_j2 - il_start(2) + 1, &
[4213]	700	& :,:) = tl_var%d_value(:,:,:,:)
	701
[5037]	702	! clean
	703	CALL var_clean(tl_var)
[4213]	704	ENDIF
	705
	706	ENDIF
	707	ENDDO
	708
[5037]	709	IF( td_var%t_dim(1)%l_use .AND. &
	710	& td_var%t_dim(1)%i_len == td_mpp%t_dim(1)%i_len )THEN
	711	IF( td_mpp%i_ew >= 0 )THEN
	712	tl_att=att_init("ew_overlap",td_mpp%i_ew)
	713	CALL var_move_att(td_var,tl_att)
	714	! clean
	715	CALL att_clean(tl_att)
	716	ENDIF
[4213]	717	ENDIF
	718
[5037]	719	! force to change _FillValue to avoid mistake
	720	! with dummy zero _FillValue
	721	IF( td_var%d_fill == 0._dp )THEN
	722	CALL var_chg_FillValue(td_var)
	723	ENDIF
[4213]	724
[5037]	725	END SUBROUTINE iom_mpp__read_var_value
[12080]	726	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	727	SUBROUTINE iom_mpp_write_file(td_mpp, cd_dimorder)
[4213]	728	!-------------------------------------------------------------------
[5037]	729	!> @brief This subroutine write files composing mpp structure.
[12080]	730	!>
[4213]	731	!> @details
[5609]	732	!> optionally, you could specify the dimension order (default 'xyzt')
[12080]	733	!>
[4213]	734	!> @author J.Paul
[5617]	735	!> @date November, 2013 - Initial Version
[12080]	736	!> @date July, 2015
	737	!> - add dimension order option
	738	!> @date August, 2017
	739	!> - handle use of domain decomposition for monoproc file
	740	!>
[5037]	741	!> @param[inout] td_mpp mpp structure
[12080]	742	!> @param[in] cd_dimorder dimension order
[4213]	743	!-------------------------------------------------------------------
[12080]	744
[4213]	745	IMPLICIT NONE
[12080]	746
[4213]	747	! Argument
[5609]	748	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
	749	CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_dimorder
[4213]	750
[5037]	751	! local variable
[4213]	752	! loop indices
	753	INTEGER(i4) :: ji
	754	!----------------------------------------------------------------
[12080]	755
[4213]	756	! check if mpp exist
	757	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	758
	759	CALL logger_error( " MPP WRITE: domain decomposition not define "//&
	760	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	761
	762	ELSE
[12080]	763	IF( td_mpp%l_usempp )THEN
	764	DO ji=1, td_mpp%i_nproc
	765	IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN
	766	CALL logger_debug("MPP WRITE: proc "//TRIM(fct_str(ji)))
	767	CALL iom_write_file(td_mpp%t_proc(ji), cd_dimorder)
	768	ELSE
	769	CALL logger_debug( " MPP WRITE: no id associated to file "//&
	770	& TRIM(td_mpp%t_proc(ji)%c_name) )
	771	ENDIF
	772	ENDDO
	773	ELSE
	774	CALL iom_write_header(td_mpp%t_proc(1), cd_dimorder, td_mpp%t_dim(:))
	775
	776	CALL iom_mpp__write_var(td_mpp, cd_dimorder)
	777	ENDIF
	778	ENDIF
	779
	780	END SUBROUTINE iom_mpp_write_file
	781	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	782	SUBROUTINE iom_mpp__write_var(td_mpp, cd_dimorder)
	783	!-------------------------------------------------------------------
	784	!> @brief This subroutine write variables from mpp structure in one output
	785	!> file.
	786	!>
	787	!> @details
	788	!> optionally, you could specify the dimension order (default 'xyzt')
	789	!>
	790	!> @author J.Paul
	791	!> @date August, 2017 - Initial Version
	792	!>
	793	!> @param[inout] td_mpp mpp structure
	794	!> @param[in] cd_dimorder dimension order
	795	!-------------------------------------------------------------------
	796
	797	IMPLICIT NONE
	798
	799	! Argument
	800	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
	801	CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_dimorder
	802
	803	! local variable
	804	INTEGER(i4), DIMENSION(4) :: il_ind
	805	INTEGER(i4) :: il_i1p
	806	INTEGER(i4) :: il_i2p
	807	INTEGER(i4) :: il_j1p
	808	INTEGER(i4) :: il_j2p
	809	INTEGER(i4) :: il_i1
	810	INTEGER(i4) :: il_i2
	811	INTEGER(i4) :: il_j1
	812	INTEGER(i4) :: il_j2
	813
	814	INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
	815	INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
	816
	817	INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
	818	INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt
	819
	820	REAL(dp) :: dl_fill
	821
	822	TYPE(TFILE) :: tl_file
	823
	824	! loop indices
	825	INTEGER(i4) :: ji
	826	INTEGER(i4) :: jj
	827	!----------------------------------------------------------------
	828
	829	! write variable in file
	830	DO jj = 1, td_mpp%i_nproc
	831
	832	! link
	833	tl_file=td_mpp%t_proc(jj)
	834	CALL logger_debug("IOM MPP WRITE: proc "//fct_str(jj))
	835
	836	! get processor indices
	837	il_ind(:)=mpp_get_proc_index( td_mpp, jj )
	838	il_i1p = il_ind(1)
	839	il_i2p = il_ind(2)
	840	il_j1p = il_ind(3)
	841	il_j2p = il_ind(4)
	842
	843	IF( jj > 1 )THEN
	844	! force to use id from variable write on first proc
	845	tl_file%t_var(:)%i_id=td_mpp%t_proc(1)%t_var(:)%i_id
	846	ENDIF
	847
	848	DO ji = 1, tl_file%i_nvar
	849
	850	IF( jj > 1 )THEN
	851	! check _FillValue
	852	dl_fill=td_mpp%t_proc(1)%t_var(ji)%d_fill
	853	IF( tl_file%t_var(ji)%d_fill /= dl_fill )THEN
	854	CALL var_chg_FillValue( tl_file%t_var(ji), dl_fill )
	855	ENDIF
[4213]	856	ENDIF
[12080]	857
	858	il_start(:)=1
	859	il_count(:)=td_mpp%t_dim(:)%i_len
	860
	861	IF( .NOT. tl_file%t_var(ji)%t_dim(1)%l_use )THEN
	862	il_i1p=1 ; il_i2p=1
	863	il_count(1) = 1
	864	ENDIF
	865	IF( .NOT. tl_file%t_var(ji)%t_dim(2)%l_use )THEN
	866	il_j1p=1 ; il_j2p=1
	867	il_count(2) = 1
	868	ENDIF
	869
	870	il_i1=MAX(il_i1p, il_start(1))
	871	il_i2=MIN(il_i2p, il_count(1))
	872
	873	il_j1=MAX(il_j1p, il_start(2))
	874	il_j2=MIN(il_j2p, il_count(2))
	875
	876	IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
	877	il_strt(:)=(/ il_i1, &
	878	& il_j1, &
	879	& 1,1 /)
	880
	881	il_cnt(:)=(/ il_i2-il_i1+1, &
	882	& il_j2-il_j1+1, &
	883	& tl_file%t_var(ji)%t_dim(3)%i_len, &
	884	& tl_file%t_var(ji)%t_dim(4)%i_len /)
	885
	886	CALL iom_write_var(tl_file, cd_dimorder, &
	887	& id_start=il_strt(:), &
	888	& id_count=il_cnt(:))
	889	ENDIF
	890
[4213]	891	ENDDO
[12080]	892	ENDDO
	893
	894	END SUBROUTINE iom_mpp__write_var
	895	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
[4213]	896	END MODULE iom_mpp

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

Download in other formats: