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 branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/TOOLS/SIREN/src – NEMO

Context Navigation

source: branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/TOOLS/SIREN/src/iom_mpp.f90 @ 10248

Last change on this file since 10248 was 10248, checked in by kingr, 5 years ago
Merged 2015/nemo_v3_6_STABLE@6232
File size: 24.1 KB

Rev	Line
[4213]	1	!----------------------------------------------------------------------
	2	! NEMO system team, System and Interface for oceanic RElocable Nesting
	3	!----------------------------------------------------------------------
	4	!
	5	! MODULE: iom_mpp
	6	!
	7	! DESCRIPTION:
[5037]	8	!> @brief This module manage massively parallel processing Input/Output manager.
	9	!> Library to read/write mpp files.
[4213]	10	!>
	11	!> @details
	12	!> to open mpp files (only file to be used (see mpp_get_use)
	13	!> will be open):<br/>
[5037]	14	!> @code
[4213]	15	!> CALL iom_mpp_open(td_mpp)
[5037]	16	!> @endcode
[4213]	17	!> - td_mpp is a mpp structure
	18	!>
	19	!> to creates mpp files:<br/>
[5037]	20	!> @code
[4213]	21	!> CALL iom_mpp_create(td_mpp)
[5037]	22	!> @endcode
[4213]	23	!> - td_mpp is a mpp structure
	24	!>
	25	!> to write in mpp files :<br/>
[5037]	26	!> @code
[4213]	27	!> CALL iom_mpp_write_file(td_mpp)
[5037]	28	!> @endcode
[4213]	29	!> - td_mpp is a mpp structure
	30	!>
	31	!> to close mpp files:<br/>
[5037]	32	!> @code
[4213]	33	!> CALL iom_mpp_close(td_mpp)
[5037]	34	!> @endcode
[4213]	35	!>
	36	!> to read one variable in an mpp files:<br/>
[5037]	37	!> @code
	38	!> tl_var=iom_mpp_read_var( td_mpp, id_varid, [id_start, id_count] [,id_ew] )
	39	!> @endcode
	40	!> or
	41	!> @code
	42	!> tl_var=iom_mpp_read_var( td_mpp, cd_name, [id_start, id_count] [,id_ew] )
	43	!> @endcode
[4213]	44	!> - td_mpp is a mpp structure
	45	!> - id_varid is a variable id
[5037]	46	!> - cd_name is variable name or standard name
	47	!> - id_start is a integer(4) 1D array of index from which the data
	48	!> values will be read [optional]
	49	!> - id_count is a integer(4) 1D array of the number of indices selected
	50	!> along each dimension [optional]
	51	!> - id_ew East West overlap [optional]
[4213]	52	!>
[5037]	53	!> to fill variable value in mpp structure:<br/>
	54	!> @code
	55	!> CALL iom_mpp_fill_var(td_mpp, id_varid, [id_start, id_count] [,id_ew] )
	56	!> @endcode
	57	!> or<br/>
	58	!> @code
	59	!> CALL iom_mpp_fill_var(td_mpp, cd_name, [id_start, id_count] [,id_ew] )
	60	!> @endcode
	61	!> - td_mpp is mpp structure
	62	!> - id_varid is variable id
	63	!> - cd_name is variable name or standard name
	64	!> - id_start is a integer(4) 1D array of index from which the data
	65	!> values will be read [optional]
	66	!> - id_count is a integer(4) 1D array of the number of indices selected
	67	!> along each dimension [optional]
	68	!> - id_ew East West overlap [optional]
[4213]	69	!>
[5037]	70	!> to fill all variable in mpp structure:<br/>
	71	!> @code
	72	!> CALL iom_mpp_fill_var(td_mpp, [id_start, id_count] [,id_ew] )
	73	!> @endcode
	74	!> - td_mpp is mpp structure
	75	!> - id_start is a integer(4) 1D array of index from which the data
	76	!> values will be read [optional]
	77	!> - id_count is a integer(4) 1D array of the number of indices selected
	78	!> along each dimension [optional]
	79	!> - id_ew East West overlap
	80	!>
	81	!> to write files composong mpp strucutre:<br/>
	82	!> @code
	83	!> CALL iom_mpp_write_file(td_mpp)
	84	!> @endcode
	85	!>
[4213]	86	!> @author
	87	!> J.Paul
	88	! REVISION HISTORY:
[10248]	89	!> @date November, 2013 - Initial Version
[5037]	90	!>
[4213]	91	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	92	!----------------------------------------------------------------------
	93	MODULE iom_mpp
	94	USE netcdf ! nf90 library
[5037]	95	USE global ! global parameter
[4213]	96	USE kind ! F90 kind parameter
	97	USE fct ! basic useful function
[5037]	98	USE logger ! log file manager
[4213]	99	USE dim ! dimension manager
	100	USE att ! attribute manager
	101	USE var ! variable manager
	102	USE file ! file manager
	103	USE iom ! I/O manager
	104	USE mpp ! mpp manager
	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
	125	!-------------------------------------------------------------------
[5037]	126	!> @brief This subroutine open files composing mpp structure to be used.
	127	!> @details
[4213]	128	!> If try to open a file in write mode that did not exist, create it.<br/>
	129	!>
	130	!> If file already exist, get information about:
	131	!> - the number of variables
	132	!> - the number of dimensions
	133	!> - the number of global attributes
	134	!> - the ID of the unlimited dimension
	135	!> - the file format
	136	!> and finally read dimensions.
	137	!>
	138	!> @author J.Paul
[10248]	139	!> @date November, 2013 - Initial Version
[4213]	140	!
[5037]	141	!> @param[inout] td_mpp mpp structure
[4213]	142	!-------------------------------------------------------------------
[5037]	143	SUBROUTINE iom_mpp_open(td_mpp, id_perio, id_ew)
[4213]	144	IMPLICIT NONE
	145	! Argument
[5037]	146	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
	147	INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
	148	INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
[4213]	149
	150	! local variable
	151	CHARACTER(LEN=lc) :: cl_name
	152
	153	! loop indices
	154	INTEGER(i4) :: ji
	155	!----------------------------------------------------------------
	156	! check if mpp exist
	157	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	158
	159	CALL logger_error( " IOM MPP OPEN: domain decomposition not define "//&
	160	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	161
	162	ELSE
[10248]	163	!
	164	td_mpp%i_id=1
	165
[5037]	166	! if no processor file selected
	167	! force to open all files
	168	IF( .NOT. ANY( td_mpp%t_proc(:)%l_use ) )THEN
	169	td_mpp%t_proc(:)%l_use=.TRUE.
	170	ENDIF
[4213]	171
[5037]	172	! add suffix to mpp name
	173	td_mpp%c_name=file_add_suffix( TRIM(td_mpp%c_name), &
	174	& TRIM(td_mpp%c_type) )
[4213]	175
[5037]	176	td_mpp%t_proc(:)%c_type=TRIM(td_mpp%c_type)
	177	IF( td_mpp%i_nproc > 1 )THEN
	178	DO ji=1,td_mpp%i_nproc
	179	IF( td_mpp%t_proc(ji)%l_use )THEN
[4213]	180
[5037]	181	SELECT CASE(TRIM(td_mpp%c_type))
	182	CASE('cdf')
	183	cl_name=TRIM( file_rename(td_mpp%c_name, ji-1) )
	184	CASE('dimg')
[4213]	185	cl_name=TRIM( file_rename(td_mpp%c_name, ji) )
[5037]	186	CASE DEFAULT
	187	CALL logger_fatal("IOM MPP OPEN: can not open file "//&
	188	& "of type "//TRIM(td_mpp%c_type))
	189	END SELECT
[4213]	190
[5037]	191	td_mpp%t_proc(ji)%c_name=TRIM(cl_name)
[4213]	192
[5037]	193	CALL iom_open(td_mpp%t_proc(ji))
[4213]	194
[5037]	195	ENDIF
	196	ENDDO
	197	ELSE ! td_mpp%i_nproc == 1
	198	cl_name=TRIM( file_rename(td_mpp%c_name) )
	199	td_mpp%t_proc(1)%c_name=TRIM(cl_name)
[4213]	200
[5037]	201	CALL iom_open(td_mpp%t_proc(1))
	202	ENDIF
[4213]	203
[5037]	204	IF( PRESENT(id_ew) )THEN
	205	td_mpp%i_ew=id_ew
	206	! add east west overlap to each variable
	207	DO ji=1,td_mpp%i_nproc
	208	WHERE(td_mpp%t_proc(ji)%t_var(:)%t_dim(1)%l_use)
	209	td_mpp%t_proc(ji)%t_var(:)%i_ew=td_mpp%i_ew
	210	ENDWHERE
	211	ENDDO
	212	ENDIF
[4213]	213
[5037]	214	IF( PRESENT(id_perio) )THEN
	215	td_mpp%i_perio=id_perio
	216	ENDIF
[4213]	217
	218	ENDIF
	219
	220	END SUBROUTINE iom_mpp_open
	221	!-------------------------------------------------------------------
	222	!> @brief This subroutine create files, composing mpp structure to be used,
[5037]	223	!> in write mode.
[4213]	224	!>
	225	!> @author J.Paul
[10248]	226	!> @date November, 2013 - Initial Version
[4213]	227	!
[5037]	228	!> @param[inout] td_mpp mpp structure
[4213]	229	!-------------------------------------------------------------------
	230	SUBROUTINE iom_mpp_create(td_mpp)
	231	IMPLICIT NONE
	232	! Argument
	233	TYPE(TMPP), INTENT(INOUT) :: td_mpp
	234	!----------------------------------------------------------------
	235	! check if mpp exist
	236	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	237
	238	CALL logger_error( " IOM MPP CREATE: domain decomposition not define "//&
	239	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	240
	241	ELSE
	242	! forced to open in write mode
	243	td_mpp%t_proc(:)%l_wrt=.TRUE.
	244	td_mpp%t_proc(:)%l_use=.TRUE.
	245	CALL iom_mpp_open(td_mpp)
	246	ENDIF
	247
	248	END SUBROUTINE iom_mpp_create
	249	!-------------------------------------------------------------------
	250	!> @brief This subroutine close files composing mpp structure.
	251	!>
	252	!> @author J.Paul
[10248]	253	!> @date November, 2013 - Initial Version
[4213]	254	!
[5037]	255	!> @param[in] td_mpp mpp structure
[4213]	256	!-------------------------------------------------------------------
	257	SUBROUTINE iom_mpp_close(td_mpp)
	258	IMPLICIT NONE
	259	! Argument
	260	TYPE(TMPP), INTENT(INOUT) :: td_mpp
	261
	262	! loop indices
	263	INTEGER(i4) :: ji
	264	!----------------------------------------------------------------
	265	! check if mpp exist
	266	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	267
	268	CALL logger_error( " IOM MPP CLOSE: domain decomposition not define "//&
	269	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	270
	271	ELSE
[10248]	272	!
	273	td_mpp%i_id=0
	274
[4213]	275	DO ji=1,td_mpp%i_nproc
	276	IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN
	277	CALL iom_close(td_mpp%t_proc(ji))
	278	ENDIF
	279	ENDDO
[5037]	280	td_mpp%t_proc(:)%l_use=.FALSE.
[4213]	281	ENDIF
	282
	283	END SUBROUTINE iom_mpp_close
	284	!-------------------------------------------------------------------
	285	!> @brief This function read variable value in opened mpp files,
[5037]	286	!> given variable id.
[4213]	287	!>
	288	!> @details
[5037]	289	!> Optionally start indices and number of point to be read could be specify.
	290	!> as well as East West ovelap of the global domain.
[4213]	291	!>
	292	!> @author J.Paul
[10248]	293	!> @date November, 2013 - Initial Version
[5037]	294	!> @date October, 2014
	295	!> - use start and count array instead of domain structure.
	296	!>
	297	!> @param[in] td_mpp mpp structure
	298	!> @param[in] id_varid variable id
	299	!> @param[in] id_start index in the variable from which the data values
	300	!> will be read
	301	!> @param[in] id_count number of indices selected along each dimension
[4213]	302	!> @return variable structure
	303	!-------------------------------------------------------------------
	304	TYPE(TVAR) FUNCTION iom_mpp__read_var_id(td_mpp, id_varid,&
[5037]	305	& id_start, id_count)
[4213]	306	IMPLICIT NONE
	307	! Argument
[5037]	308	TYPE(TMPP), INTENT(IN) :: td_mpp
	309	INTEGER(i4), INTENT(IN) :: id_varid
	310	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
	311	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
[4213]	312
	313	! local variable
	314	INTEGER(i4), DIMENSION(1) :: il_ind
	315	!----------------------------------------------------------------
	316	! check if mpp exist
	317	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	318
	319	CALL logger_error( " IOM MPP READ VAR: domain decomposition not define "//&
	320	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	321
[10248]	322	ELSEIF( td_mpp%i_id == 0 )THEN
	323
	324	CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//&
	325	& " can not read variable in "//TRIM(td_mpp%c_name))
	326
[4213]	327	ELSE
	328
[10248]	329
[4213]	330	IF( ANY(td_mpp%t_proc(:)%i_id /= 0) )THEN
	331	! look for variable id
	332	il_ind(:)=MINLOC( td_mpp%t_proc(1)%t_var(:)%i_id, &
	333	& mask=(td_mpp%t_proc(1)%t_var(:)%i_id==id_varid))
	334	IF( il_ind(1) /= 0 )THEN
	335
[5037]	336	iom_mpp__read_var_id=var_copy(td_mpp%t_proc(1)%t_var(il_ind(1)))
[4213]	337
	338	!!! read variable value
	339	CALL iom_mpp__read_var_value(td_mpp, iom_mpp__read_var_id, &
[5037]	340	& id_start, id_count)
[4213]	341
	342	ELSE
	343	CALL logger_error( &
	344	& " IOM MPP READ VAR: there is no variable with id "//&
	345	& TRIM(fct_str(id_varid))//" in processor/file "//&
	346	& TRIM(td_mpp%t_proc(1)%c_name))
	347	ENDIF
	348	ELSE
	349	CALL logger_error(" IOM MPP READ VAR: can't read variable, mpp "//&
	350	& TRIM(td_mpp%c_name)//" not opened")
	351	ENDIF
	352
	353	ENDIF
	354
	355	END FUNCTION iom_mpp__read_var_id
	356	!-------------------------------------------------------------------
	357	!> @brief This function read variable value in opened mpp files,
[5037]	358	!> given variable name or standard name.
	359	!>
[4213]	360	!> @details
[5037]	361	!> Optionally start indices and number of point to be read could be specify.
	362	!> as well as East West ovelap of the global domain.
	363	!>
[4213]	364	!> look first for variable name. If it doesn't
	365	!> exist in file, look for variable standard name.<br/>
	366	!> If variable name is not present, check variable standard name.<br/>
	367	!
	368	!> @author J.Paul
[10248]	369	!> @date November, 2013 - Initial Version
[5037]	370	!> @date October, 2014
	371	!> - use start and count array instead of domain structure.
[4213]	372	!
[5037]	373	!> @param[in] td_mpp mpp structure
	374	!> @param[in] cd_name variable name
	375	!> @param[in] id_start index in the variable from which the data values
	376	!> will be read
	377	!> @param[in] id_count number of indices selected along each dimension
[4213]	378	!> @return variable structure
	379	!-------------------------------------------------------------------
	380	TYPE(TVAR) FUNCTION iom_mpp__read_var_name(td_mpp, cd_name, &
[5037]	381	& id_start, id_count )
[4213]	382	IMPLICIT NONE
	383	! Argument
[5037]	384	TYPE(TMPP), INTENT(IN) :: td_mpp
	385	CHARACTER(LEN=*), INTENT(IN) :: cd_name
	386	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
	387	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
[4213]	388
	389	! local variable
[5037]	390	INTEGER(i4) :: il_ind
[4213]	391	!----------------------------------------------------------------
	392	! check if mpp exist
	393	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	394
	395	CALL logger_error( " IOM MPP READ VAR: domain decomposition not define "//&
	396	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	397
[10248]	398	ELSEIF( td_mpp%i_id == 0 )THEN
	399
	400	CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//&
	401	& " can not read variable in "//TRIM(td_mpp%c_name))
	402
[4213]	403	ELSE
	404
[5037]	405	il_ind=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name)
	406	IF( il_ind /= 0 )THEN
[4213]	407
[5037]	408	iom_mpp__read_var_name=var_copy(td_mpp%t_proc(1)%t_var(il_ind))
[4213]	409
	410	!!! read variable value
	411	CALL iom_mpp__read_var_value( td_mpp, &
	412	& iom_mpp__read_var_name, &
[5037]	413	& id_start, id_count)
[4213]	414
	415	ELSE
	416
	417	CALL logger_error( &
	418	& " IOM MPP READ VAR: there is no variable with "//&
[10248]	419	& "name or standard name "//TRIM(cd_name)//&
[4213]	420	& " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name))
	421	ENDIF
	422
	423	ENDIF
	424
	425	END FUNCTION iom_mpp__read_var_name
	426	!-------------------------------------------------------------------
	427	!> @brief This subroutine read variable value
	428	!> in an mpp structure.
	429	!>
	430	!> @details
[5037]	431	!> Optionally start indices and number of point to be read could be specify.
	432	!> as well as East West ovelap of the global domain.
[4213]	433	!
	434	!> @author J.Paul
[10248]	435	!> @date November, 2013 - Initial Version
[5037]	436	!> @date October, 2014
	437	!> - use start and count array instead of domain structure.
	438	!>
	439	!> @param[in] td_mpp mpp structure
	440	!> @param[inout] td_var variable structure
	441	!> @param[in] id_start index in the variable from which the data values
	442	!> will be read
	443	!> @param[in] id_count number of indices selected along each dimension
[4213]	444	!-------------------------------------------------------------------
	445	SUBROUTINE iom_mpp__read_var_value(td_mpp, td_var, &
[5037]	446	& id_start, id_count )
[4213]	447	IMPLICIT NONE
	448	! Argument
	449	TYPE(TMPP), INTENT(IN) :: td_mpp
	450	TYPE(TVAR), INTENT(INOUT) :: td_var
[5037]	451	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
	452	INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
[4213]	453
	454	! local variable
	455	INTEGER(i4) :: il_status
	456	INTEGER(i4), DIMENSION(4) :: il_ind
	457	INTEGER(i4) :: il_i1p
	458	INTEGER(i4) :: il_i2p
	459	INTEGER(i4) :: il_j1p
	460	INTEGER(i4) :: il_j2p
[5037]	461	INTEGER(i4) :: il_i1
	462	INTEGER(i4) :: il_i2
	463	INTEGER(i4) :: il_j1
	464	INTEGER(i4) :: il_j2
[4213]	465
[5037]	466	INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
	467	INTEGER(i4), DIMENSION(ip_maxdim) :: il_end
	468	INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
	469
	470	INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
	471	INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt
	472
	473	TYPE(TATT) :: tl_att
[4213]	474	TYPE(TVAR) :: tl_var
	475
	476	! loop indices
	477	INTEGER(i4) :: jk
	478	!----------------------------------------------------------------
	479
[5037]	480	il_start(:)=1
	481	IF( PRESENT(id_start) ) il_start(:)=id_start(:)
[4213]	482
[5037]	483	il_count(:)=td_mpp%t_dim(:)%i_len
	484	IF( PRESENT(id_count) ) il_count(:)=id_count(:)
[4213]	485
[10248]	486	CALL logger_debug("IOM MPP READ VAR VALUE: start "//&
	487	& TRIM(fct_str(il_start(jp_I)))//","//&
	488	& TRIM(fct_str(il_start(jp_J)))//","//&
	489	& TRIM(fct_str(il_start(jp_K)))//","//&
	490	& TRIM(fct_str(il_start(jp_L))) )
	491	CALL logger_debug("IOM MPP READ VAR VALUE: count "//&
	492	& TRIM(fct_str(il_count(jp_I)))//","//&
	493	& TRIM(fct_str(il_count(jp_J)))//","//&
	494	& TRIM(fct_str(il_count(jp_K)))//","//&
	495	& TRIM(fct_str(il_count(jp_L))) )
	496
[5037]	497	DO jk=1,ip_maxdim
	498	IF( .NOT. td_var%t_dim(jk)%l_use )THEN
	499	il_start(jk) = 1
	500	il_count(jk) = 1
[4213]	501	ENDIF
	502
[5037]	503	il_end(jk)=il_start(jk)+il_count(jk)-1
	504	ENDDO
[4213]	505
[5037]	506	IF( ANY(il_end(:) > td_mpp%t_dim(:)%i_len) )THEN
[10248]	507	CALL logger_debug("IOM MPP READ VAR VALUE: start + count "//&
	508	& TRIM(fct_str(il_end(jp_I)))//","//&
	509	& TRIM(fct_str(il_end(jp_J)))//","//&
	510	& TRIM(fct_str(il_end(jp_K)))//","//&
	511	& TRIM(fct_str(il_end(jp_L))) )
	512	CALL logger_debug("IOM MPP READ VAR VALUE: dimension "//&
	513	& TRIM(fct_str(td_mpp%t_dim(jp_I)%i_len))//","//&
	514	& TRIM(fct_str(td_mpp%t_dim(jp_J)%i_len))//","//&
	515	& TRIM(fct_str(td_mpp%t_dim(jp_K)%i_len))//","//&
	516	& TRIM(fct_str(td_mpp%t_dim(jp_L)%i_len)) )
[5037]	517	CALL logger_fatal("IOM MPP READ VAR VALUE: start + count "//&
	518	& "exceed dimension bound.")
[4213]	519	ENDIF
	520
[5037]	521	! use domain dimension
	522	td_var%t_dim(:)%i_len=il_count(:)
[4213]	523
[5037]	524	! Allocate space to hold variable value in structure
	525	IF( ASSOCIATED(td_var%d_value) )THEN
	526	DEALLOCATE(td_var%d_value)
[4213]	527	ENDIF
	528
[5037]	529	ALLOCATE(td_var%d_value( il_count(1), &
	530	& il_count(2), &
	531	& il_count(3), &
	532	& il_count(4)),&
	533	& stat=il_status)
	534	IF(il_status /= 0 )THEN
[4213]	535
[5037]	536	CALL logger_error( &
	537	& " IOM MPP READ VAR VALUE: not enough space to put variable "//&
	538	& TRIM(td_var%c_name)//&
	539	& " in variable structure")
[4213]	540
	541	ENDIF
	542
[5037]	543	CALL logger_debug("IOM MPP READ VAR VALUE: shape ("//&
	544	& TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//&
	545	& TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//&
	546	& TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//&
	547	& TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" )
	548	! FillValue by default
	549	td_var%d_value(:,:,:,:)=td_var%d_fill
[4213]	550
	551	! read processor
	552	DO jk=1,td_mpp%i_nproc
	553	IF( td_mpp%t_proc(jk)%l_use )THEN
	554
	555	! get processor indices
	556	il_ind(:)=mpp_get_proc_index( td_mpp, jk )
	557	il_i1p = il_ind(1)
	558	il_i2p = il_ind(2)
	559	il_j1p = il_ind(3)
	560	il_j2p = il_ind(4)
[5037]	561
[4213]	562	IF( .NOT. td_var%t_dim(1)%l_use )THEN
[5037]	563	il_i1p=il_start(1) ; il_i2p=il_end(1)
[4213]	564	ENDIF
	565	IF( .NOT. td_var%t_dim(2)%l_use )THEN
[5037]	566	il_j1p=il_start(2) ; il_j2p=il_end(2)
	567	ENDIF
	568
	569	il_i1=MAX(il_i1p, il_start(1))
	570	il_i2=MIN(il_i2p, il_end(1))
[4213]	571
[5037]	572	il_j1=MAX(il_j1p, il_start(2))
	573	il_j2=MIN(il_j2p, il_end(2))
[4213]	574
	575	IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
[5037]	576	il_strt(:)=(/ il_i1-il_i1p+1, &
	577	& il_j1-il_j1p+1, &
	578	& 1,1 /)
[4213]	579
[5037]	580	il_cnt(:)=(/ il_i2-il_i1+1, &
	581	& il_j2-il_j1+1, &
	582	& td_var%t_dim(3)%i_len, &
	583	& td_var%t_dim(4)%i_len /)
[4213]	584
	585	tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,&
[5037]	586	& il_strt(:), il_cnt(:) )
[4213]	587	! replace value in output variable structure
[5037]	588	td_var%d_value( il_i1 - il_start(1) + 1 : &
	589	& il_i2 - il_start(1) + 1, &
	590	& il_j1 - il_start(2) + 1 : &
	591	& il_j2 - il_start(2) + 1, &
[4213]	592	& :,:) = tl_var%d_value(:,:,:,:)
	593
[5037]	594	! clean
	595	CALL var_clean(tl_var)
[4213]	596	ENDIF
	597
	598	ENDIF
	599	ENDDO
	600
[5037]	601	IF( td_var%t_dim(1)%l_use .AND. &
	602	& td_var%t_dim(1)%i_len == td_mpp%t_dim(1)%i_len )THEN
	603	IF( td_mpp%i_ew >= 0 )THEN
	604	tl_att=att_init("ew_overlap",td_mpp%i_ew)
	605	CALL var_move_att(td_var,tl_att)
	606	! clean
	607	CALL att_clean(tl_att)
	608	ENDIF
[4213]	609	ENDIF
	610
[5037]	611	! force to change _FillValue to avoid mistake
	612	! with dummy zero _FillValue
	613	IF( td_var%d_fill == 0._dp )THEN
	614	CALL var_chg_FillValue(td_var)
	615	ENDIF
[4213]	616
[5037]	617	END SUBROUTINE iom_mpp__read_var_value
[4213]	618	!-------------------------------------------------------------------
[5037]	619	!> @brief This subroutine write files composing mpp structure.
[4213]	620	!
	621	!> @details
[10248]	622	!> optionally, you could specify the dimension order (default 'xyzt')
[4213]	623	!
	624	!> @author J.Paul
[10248]	625	!> @date November, 2013 - Initial Version
	626	!> @date July, 2015 - add dimension order option
[4213]	627	!
[5037]	628	!> @param[inout] td_mpp mpp structure
[10248]	629	!> @param[In] cd_dimorder dimension order
[4213]	630	!-------------------------------------------------------------------
[10248]	631	SUBROUTINE iom_mpp_write_file(td_mpp, cd_dimorder)
[4213]	632	IMPLICIT NONE
	633	! Argument
[10248]	634	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
	635	CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_dimorder
[4213]	636
[5037]	637	! local variable
[4213]	638	! loop indices
	639	INTEGER(i4) :: ji
	640	!----------------------------------------------------------------
	641	! check if mpp exist
	642	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
	643
	644	CALL logger_error( " MPP WRITE: domain decomposition not define "//&
	645	& " in mpp strcuture "//TRIM(td_mpp%c_name))
	646
	647	ELSE
	648	DO ji=1, td_mpp%i_nproc
	649	IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN
[5037]	650	!CALL file_del_att(td_mpp%t_proc(ji), 'periodicity')
	651	!CALL file_del_att(td_mpp%t_proc(ji), 'ew_overlap')
	652
[10248]	653	CALL iom_write_file(td_mpp%t_proc(ji), cd_dimorder)
[4213]	654	ELSE
	655	CALL logger_debug( " MPP WRITE: no id associated to file "//&
	656	& TRIM(td_mpp%t_proc(ji)%c_name) )
	657	ENDIF
	658	ENDDO
	659	ENDIF
	660	END SUBROUTINE iom_mpp_write_file
	661	END MODULE iom_mpp

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

Download in other formats: