Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

ioipsl_para.f90 @ 5558

Last change on this file since 5558 was 4977, checked in by simon.bowring, 6 years ago
Currently running (13/02/2018) version includes all necessarily changes to include DOC in MICT code... further parametrisation necessary to equate soil pools with those of normal forcesoil restarts
Property svn:keywords set to `HeadURL Date Author Revision`
File size: 60.3 KB

Line
1	! ==============================================================================================================================
2	! MODULE : ioipls_para
3	!
4	! CONTACT : orchidee-help _at_ listes.ipsl.fr
5	!
6	! LICENCE : IPSL (2006)
7	! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8	!
9	!>\BRIEF Overlap of IOIPSL functions for specific parallel use in ORCHIDEE.
10	!!
11	!!\n DESCRIPTION: This module contains interfaces for some IOIPSL subroutines adapted to be used in parallel mode by ORCHIDEE.
12	!!
13	!! Following interfaces are available :
14	!! - getin_p : Read a variable from run.def file. The master process will call getin in IOIPSL.
15	!! The same result will be known by all processes after the call.
16	!! The variable can be an integer, real, logical or character string. It can be a scalar or
17	!! have 1 or 2 dimensions except for character string which can only be scalar or have 1 dimension.
18	!! - restget_p : Read a variable from restart file. The master process will call the subroutine restget in IOIPSL.
19	!! The variable will be distributed on the local domain for each process.
20	!! The variable must be a real and can have 1, 2 or 3 dimensions. It can not be a scalar.
21	!! - restput_p : Write a variable to restart file. The master process will call the subroutine restput in IOIPSL.
22	!! The input variable must be given on the local domain for each process.
23	!! The variable must be a real and can have 1, 2 or 3 dimensions. It can not be a scalar.
24	!! - histwrite_p : Write a variable to history file. The master process will call the subroutine histwrite in IOIPSL.
25	!! The input variable must be given on the local domain for each process.
26	!! The variable must be a real and can have 1, 2 or 3 dimensions. It can not be a scalar.
27	!!
28	!! Note that these subroutines must be called by all MPI processes and all OMP thredds because they contain
29	!! all a MPI blocker function.
30	!!
31	!!
32	!!
33	!! RECENT CHANGE(S): None
34	!!
35	!! REFERENCES(S) : None
36	!!
37	!! SVN :
38	!! $HeadURL$
39	!! $Date$
40	!! $Revision$
41	!! \n
42	!_ ================================================================================================================================
43
44	MODULE ioipsl_para
45	USE ioipsl
46	USE mod_orchidee_para_var
47	USE mod_orchidee_transfert_para
48	USE constantes_var
49	!-
50	IMPLICIT NONE
51
52	INTEGER, SAVE :: orch_domain_id
53	!-
54	INTEGER :: orch_ipslout=6, orch_ilv_cur=0, orch_ilv_max=0
55	!$OMP THREADPRIVATE( orch_ipslout, orch_ilv_cur, orch_ilv_max )
56
57	!-
58	!-
59	#include "src_parallel.h"
60	!-
61	!! ==============================================================================================================================
62	!! INTERFACE : getin_p
63	!!
64	!>\BRIEF interface to parallelize the call to getin in IOIPSL
65	!!
66	!! DESCRIPTION : get a variable from a text input file. Need to be call by all process
67	!!
68	!! \n
69	!_ ================================================================================================================================
70	INTERFACE getin_p
71	MODULE PROCEDURE getin_p_c,getin_p_c1, &
72	getin_p_i,getin_p_i1,getin_p_i2,&
73	getin_p_r,getin_p_r1,getin_p_r2,&
74	getin_p_l,getin_p_l1,getin_p_l2
75	END INTERFACE
76	!-
77	!! ==============================================================================================================================
78	!! INTERFACE : restput_p
79	!!
80	!>\BRIEF interface to parallelize the call to restput in IOIPSL
81	!!
82	!! DESCRIPTION : allows to re-index data onto the original grid of the restart file. Need to be call by all process
83	!!
84	!! \n
85	!_ ================================================================================================================================
86	INTERFACE restput_p
87	MODULE PROCEDURE &
88	restput_p_r3d, restput_p_r2d, restput_p_r1d, &
89	restput_p_opp_r5d, restput_p_opp_r4d, restput_p_opp_r3d, &
90	restput_p_opp_r2d, restput_p_opp_r1d, restput_p_nogrid_r1d, &
91	restput_p_nogrid_i_scal, restput_p_nogrid_r_scal, &
92	restput_p_opp_i1d, restput_p_opp_i2d, restput_p_opp_i3d, &
93	restput_p_opp_i4d, restput_p_opp_i5d
94	END INTERFACE
95	!-
96	!! ==============================================================================================================================
97	!! INTERFACE : restget_p
98	!!
99	!>\BRIEF interface to parallelize the call to restget in IOIPSL
100	!!
101	!! DESCRIPTION : Transform the data from the restart file onto the model grid.
102	!!
103	!! \n
104	!_ ================================================================================================================================
105	INTERFACE restget_p
106	MODULE PROCEDURE &
107	restget_p_r3d, restget_p_r2d, restget_p_r1d, &
108	restget_p_opp_r5d, restget_p_opp_r4d, restget_p_opp_r3d, &
109	restget_p_opp_r2d, restget_p_opp_r1d, restget_p_nogrid_r1d, &
110	restget_p_nogrid_r_scal, restget_p_nogrid_i_scal, &
111	restget_p_opp_i1d, restget_p_opp_i2d, restget_p_opp_i3d, &
112	restget_p_opp_i4d, restget_p_opp_i5d
113	END INTERFACE
114
115	!! ==============================================================================================================================
116	!! INTERFACE : histwrite_p
117	!!
118	!>\BRIEF interface to parallelize the call to histwrite in IOIPSL
119	!!
120	!! DESCRIPTION : give the data to the IOIPSL system (if we don't use XIOS). Need to be call by all process
121	!!
122	!! \n
123	!_ ================================================================================================================================
124
125	INTERFACE histwrite_p
126	MODULE PROCEDURE &
127	histwrite_r1d_p,histwrite_r2d_p,histwrite_r3d_p
128	END INTERFACE
129
130	CONTAINS
131
132
133	!! =============================================================================================================================
134	!! SUBROUTINE: Init_ioipsl_para
135	!!
136	!>\BRIEF call to IOIPSL routine : flio_dom_set
137	!!
138	!! DESCRIPTION: will sets up the domain activity of IOIPSL. Need to be call by all process
139	!!
140	!! \n
141	!_ ==============================================================================================================================
142
143	SUBROUTINE Init_ioipsl_para
144
145	IMPLICIT NONE
146
147	INTEGER,DIMENSION(2) :: ddid
148	INTEGER,DIMENSION(2) :: dsg
149	INTEGER,DIMENSION(2) :: dsl
150	INTEGER,DIMENSION(2) :: dpf
151	INTEGER,DIMENSION(2) :: dpl
152	INTEGER,DIMENSION(2) :: dhs
153	INTEGER,DIMENSION(2) :: dhe
154
155	IF (is_omp_root) THEN
156	ddid=(/ 1,2 /)
157	dsg=(/ iim_g, jjm_g /)
158	dsl=(/ iim_g, jj_nb /)
159	dpf=(/ 1,jj_begin /)
160	dpl=(/ iim_g, jj_end /)
161	dhs=(/ ii_begin-1,0 /)
162	if (mpi_rank==mpi_size-1) then
163	dhe=(/0,0/)
164	else
165	dhe=(/ iim_g-ii_end,0 /)
166	endif
167
168	call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
169	'APPLE',orch_domain_id)
170	ENDIF
171
172	END SUBROUTINE Init_ioipsl_para
173
174	!! =============================================================================================================================
175	!! SUBROUTINE: ioconf_setatt_p
176	!!
177	!>\BRIEF parallelisation of the call to IOIPSL routine ioconf_setatt
178	!!
179	!! DESCRIPTION: NONE
180	!!
181	!! \n
182	!_ ==============================================================================================================================
183	SUBROUTINE ioconf_setatt_p (attname,attvalue)
184	!---------------------------------------------------------------------
185	IMPLICIT NONE
186	!-
187	CHARACTER(LEN=*), INTENT(in) :: attname,attvalue
188	!---------------------------------------------------------------------
189
190	IF (is_root_prc) THEN
191	CALL ioconf_setatt(attname,attvalue)
192	ENDIF
193
194	END SUBROUTINE ioconf_setatt_p
195
196	!! =============================================================================================================================
197	!! SUBROUTINE: ipslnlf_p
198	!!
199	!>\BRIEF parallelisation of the call to IOIPSL routine ipslnlf
200	!!
201	!! DESCRIPTION: The "ipslnlf" routine allows to know and modify the current logical number for the messages.
202	!!
203	!! \n
204	!_ ==============================================================================================================================
205	SUBROUTINE ipslnlf_p (new_number,old_number)
206	!!--------------------------------------------------------------------
207	!! The "ipslnlf" routine allows to know and modify
208	!! the current logical number for the messages.
209	!!
210	!! SUBROUTINE ipslnlf (new_number,old_number)
211	!!
212	!! Optional INPUT argument
213	!!
214	!! (I) new_number : new logical number of the file
215	!!
216	!! Optional OUTPUT argument
217	!!
218	!! (I) old_number : current logical number of the file
219	!!--------------------------------------------------------------------
220	IMPLICIT NONE
221	!-
222	INTEGER,OPTIONAL,INTENT(IN) :: new_number
223	INTEGER,OPTIONAL,INTENT(OUT) :: old_number
224	!---------------------------------------------------------------------
225	IF (PRESENT(old_number)) THEN
226	#ifndef CPP_OMP
227	CALL ipslnlf(old_number=orch_ipslout)
228	#endif
229	old_number = orch_ipslout
230	ENDIF
231	IF (PRESENT(new_number)) THEN
232	orch_ipslout = new_number
233	#ifndef CPP_OMP
234	CALL ipslnlf(new_number=orch_ipslout)
235	#endif
236	ENDIF
237
238	END SUBROUTINE ipslnlf_p
239
240	!! =============================================================================================================================
241	!! SUBROUTINE: ipslerr_p
242	!!
243	!>\BRIEF allows to handle the messages to the user.
244	!!
245	!! DESCRIPTION: NONE
246	!!
247	!! \n
248	!_ ==============================================================================================================================
249	!===
250	SUBROUTINE ipslerr_p (plev,pcname,pstr1,pstr2,pstr3)
251	!---------------------------------------------------------------------
252	!! The "ipslerr_p" routine
253	!! allows to handle the messages to the user.
254	!!
255	!! parallel version of IOIPSL ipslerr
256	!!
257	!! INPUT
258	!!
259	!! plev : Category of message to be reported to the user
260	!! 1 = Note to the user
261	!! 2 = Warning to the user
262	!! 3 = Fatal error
263	!! pcname : Name of subroutine which has called ipslerr
264	!! pstr1
265	!! pstr2 : Strings containing the explanations to the user
266	!! pstr3
267	!---------------------------------------------------------------------
268	IMPLICIT NONE
269	!-
270	INTEGER :: plev
271	CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
272	!-
273	CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
274	& (/ "NOTE TO THE USER FROM ROUTINE ", &
275	& "WARNING FROM ROUTINE ", &
276	& "FATAL ERROR FROM ROUTINE " /)
277	!---------------------------------------------------------------------
278	IF ( (plev >= 1).AND.(plev <= 3) ) THEN
279	orch_ilv_cur = plev
280	orch_ilv_max = MAX(orch_ilv_max,plev)
281	WRITE(orch_ipslout,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
282	WRITE(orch_ipslout,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3)
283	ENDIF
284	IF (plev == 3) THEN
285	WRITE(orch_ipslout,'("Fatal error from ORCHIDEE. STOP in ipslerr_p with code")')
286	#if defined (__INTEL_COMPILER) \|\| defined(__GFORTRAN__)
287	CALL FLUSH(orch_ipslout)
288	#endif
289
290	#ifdef CPP_PARA
291	CALL MPI_ABORT(plev)
292	#endif
293	STOP 1
294	ENDIF
295	!---------------------
296	END SUBROUTINE ipslerr_p
297
298
299	!! =============================================================================================================================
300	!! SUBROUTINE: getin_p_c
301	!!
302	!>\BRIEF get a character variable in text input file
303	!!
304	!! DESCRIPTION: Need to be call by all process
305	!!
306	!! \n
307	!_ ==============================================================================================================================
308	SUBROUTINE getin_p_c(VarIn,VarOut)
309	IMPLICIT NONE
310	CHARACTER(LEN=*),INTENT(IN) :: VarIn
311	CHARACTER(LEN=*),INTENT(INOUT) :: VarOut
312
313	IF (is_root_prc) CALL getin(VarIn,VarOut)
314	CALL bcast(VarOut)
315	END SUBROUTINE getin_p_c
316
317	!! =============================================================================================================================
318	!! SUBROUTINE: getin_p_c1
319	!!
320	!>\BRIEF get a character 1D array in text input file
321	!!
322	!! DESCRIPTION: Need to be call by all process
323	!!
324	!! \n
325	!_ ==============================================================================================================================
326	SUBROUTINE getin_p_c1(VarIn,VarOut)
327	IMPLICIT NONE
328	CHARACTER(LEN=*),INTENT(IN) :: VarIn
329	CHARACTER(LEN=*),INTENT(INOUT) :: VarOut(:)
330
331	IF (is_root_prc) CALL getin(VarIn,VarOut)
332	CALL bcast(VarOut)
333	END SUBROUTINE getin_p_c1
334
335	!! =============================================================================================================================
336	!! SUBROUTINE: getin_p_i
337	!!
338	!>\BRIEF get an integer variable in text input file
339	!!
340	!! DESCRIPTION: Need to be call by all process
341	!!
342	!! \n
343	!_ ==============================================================================================================================
344	SUBROUTINE getin_p_i(VarIn,VarOut)
345	IMPLICIT NONE
346	CHARACTER(LEN=*),INTENT(IN) :: VarIn
347	INTEGER,INTENT(INOUT) :: VarOut
348
349	IF (is_root_prc) CALL getin(VarIn,VarOut)
350	CALL bcast(VarOut)
351	END SUBROUTINE getin_p_i
352
353	!! =============================================================================================================================
354	!! SUBROUTINE: getin_p_i1
355	!!
356	!>\BRIEF get an integer 1D array in text input file
357	!!
358	!! DESCRIPTION: Need to be call by all process
359	!!
360	!! \n
361	!_ ==============================================================================================================================
362	SUBROUTINE getin_p_i1(VarIn,VarOut)
363	IMPLICIT NONE
364	CHARACTER(LEN=*),INTENT(IN) :: VarIn
365	INTEGER,INTENT(INOUT) :: VarOut(:)
366
367	IF (is_root_prc) CALL getin(VarIn,VarOut)
368	CALL bcast(VarOut)
369	END SUBROUTINE getin_p_i1
370
371	!! =============================================================================================================================
372	!! SUBROUTINE: getin_p_i2
373	!!
374	!>\BRIEF get an integer 2D array in text input file
375	!!
376	!! DESCRIPTION: Need to be call by all process
377	!!
378	!! \n
379	!_ ==============================================================================================================================
380	SUBROUTINE getin_p_i2(VarIn,VarOut)
381	IMPLICIT NONE
382	CHARACTER(LEN=*),INTENT(IN) :: VarIn
383	INTEGER,INTENT(INOUT) :: VarOut(:,:)
384
385	IF (is_root_prc) CALL getin(VarIn,VarOut)
386	CALL bcast(VarOut)
387	END SUBROUTINE getin_p_i2
388
389	!! =============================================================================================================================
390	!! SUBROUTINE: getin_p_r
391	!!
392	!>\BRIEF get a float variable in text input file
393	!!
394	!! DESCRIPTION: Need to be call by all process
395	!!
396	!! \n
397	!_ ==============================================================================================================================
398	SUBROUTINE getin_p_r(VarIn,VarOut)
399	IMPLICIT NONE
400	CHARACTER(LEN=*),INTENT(IN) :: VarIn
401	REAL,INTENT(INOUT) :: VarOut
402
403	IF (is_root_prc) CALL getin(VarIn,VarOut)
404	CALL bcast(VarOut)
405	END SUBROUTINE getin_p_r
406
407	!! =============================================================================================================================
408	!! SUBROUTINE: getin_p_r1
409	!!
410	!>\BRIEF get a float 1D array in text input file
411	!!
412	!! DESCRIPTION: Need to be call by all process
413	!!
414	!! \n
415	!_ ==============================================================================================================================
416	SUBROUTINE getin_p_r1(VarIn,VarOut)
417	IMPLICIT NONE
418	CHARACTER(LEN=*),INTENT(IN) :: VarIn
419	REAL,INTENT(INOUT) :: VarOut(:)
420
421	IF (is_root_prc) CALL getin(VarIn,VarOut)
422	CALL bcast(VarOut)
423	END SUBROUTINE getin_p_r1
424
425	!! =============================================================================================================================
426	!! SUBROUTINE: getin_p_r2
427	!!
428	!>\BRIEF get a float 2D array in text input file
429	!!
430	!! DESCRIPTION: Need to be call by all process
431	!!
432	!! \n
433	!_ ==============================================================================================================================
434	SUBROUTINE getin_p_r2(VarIn,VarOut)
435	IMPLICIT NONE
436	CHARACTER(LEN=*),INTENT(IN) :: VarIn
437	REAL,INTENT(INOUT) :: VarOut(:,:)
438
439	IF (is_root_prc) CALL getin(VarIn,VarOut)
440	CALL bcast(VarOut)
441	END SUBROUTINE getin_p_r2
442
443
444	!! =============================================================================================================================
445	!! SUBROUTINE: getin_p_l
446	!!
447	!>\BRIEF get a logical variable in text input file
448	!!
449	!! DESCRIPTION: Need to be call by all process
450	!!
451	!! \n
452	!_ ==============================================================================================================================
453	SUBROUTINE getin_p_l(VarIn,VarOut)
454	IMPLICIT NONE
455	CHARACTER(LEN=*),INTENT(IN) :: VarIn
456	LOGICAL,INTENT(INOUT) :: VarOut
457
458	IF (is_root_prc) CALL getin(VarIn,VarOut)
459	CALL bcast(VarOut)
460	END SUBROUTINE getin_p_l
461
462	!! =============================================================================================================================
463	!! SUBROUTINE: getin_p_l1
464	!!
465	!>\BRIEF get a logical 1D array in text input file
466	!!
467	!! DESCRIPTION: Need to be call by all process
468	!!
469	!! \n
470	!_ ==============================================================================================================================
471	SUBROUTINE getin_p_l1(VarIn,VarOut)
472	IMPLICIT NONE
473	CHARACTER(LEN=*),INTENT(IN) :: VarIn
474	LOGICAL,INTENT(INOUT) :: VarOut(:)
475
476	IF (is_root_prc) CALL getin(VarIn,VarOut)
477	CALL bcast(VarOut)
478	END SUBROUTINE getin_p_l1
479
480	!! =============================================================================================================================
481	!! SUBROUTINE: getin_p_l2
482	!!
483	!>\BRIEF get a logical 2D array in text input file
484	!!
485	!! DESCRIPTION: Need to be call by all process
486	!!
487	!! \n
488	!_ ==============================================================================================================================
489	SUBROUTINE getin_p_l2(VarIn,VarOut)
490	IMPLICIT NONE
491	CHARACTER(LEN=*),INTENT(IN) :: VarIn
492	LOGICAL,INTENT(INOUT) :: VarOut(:,:)
493
494	IF (is_root_prc) CALL getin(VarIn,VarOut)
495	CALL bcast(VarOut)
496	END SUBROUTINE getin_p_l2
497	!-
498
499	!! =============================================================================================================================
500	!! SUBROUTINE: restget_p_opp_r1d
501	!!
502	!>\BRIEF Transform the data (real 1D) from the restart file onto the model grid with the operation MY_OPERATOR
503	!!
504	!! DESCRIPTION: do not use this function with non grid variable
505	!!
506	!! \n
507	!_ ==============================================================================================================================
508	SUBROUTINE restget_p_opp_r1d &
509	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
510	var, MY_OPERATOR, nbindex, ijndex)
511	! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
512	IMPLICIT NONE
513	!-
514	INTEGER :: fid
515	CHARACTER(LEN=*) :: vname_q
516	INTEGER :: iim, jjm, llm, itau
517	LOGICAL def_beha
518	REAL :: var(:)
519	CHARACTER(LEN=*) :: MY_OPERATOR
520	INTEGER :: nbindex, ijndex(nbindex)
521	!-----------------------------
522	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
523
524	IF (is_root_prc) THEN
525	ALLOCATE( temp_g(iimjjmllm) )
526	ELSE
527	ALLOCATE( temp_g(1) )
528	ENDIF
529
530	IF (is_root_prc) THEN
531	CALL restget &
532	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
533	temp_g, MY_OPERATOR, nbindex, ijndex)
534	ENDIF
535	CALL scatter(temp_g,var)
536	DEALLOCATE(temp_g)
537	END SUBROUTINE restget_p_opp_r1d
538
539	!! =============================================================================================================================
540	!! SUBROUTINE: restget_p_opp_r2d
541	!!
542	!>\BRIEF Transform the data (real 2D) from the restart file onto the model grid with the operation MY_OPERATOR
543	!!
544	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
545	!!
546	!! \n
547	!_ ==============================================================================================================================
548	SUBROUTINE restget_p_opp_r2d &
549	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
550	var, MY_OPERATOR, nbindex, ijndex)
551	IMPLICIT NONE
552	!-
553	INTEGER :: fid
554	CHARACTER(LEN=*) :: vname_q
555	INTEGER :: iim, jjm, llm, itau
556	LOGICAL def_beha
557	REAL :: var(:,:)
558	CHARACTER(LEN=*) :: MY_OPERATOR
559	INTEGER :: nbindex, ijndex(nbindex)
560	!-----------------------------
561	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
562
563	IF (is_root_prc) THEN
564	ALLOCATE( temp_g(iim,jjm) )
565	ELSE
566	ALLOCATE( temp_g(1,1) )
567	ENDIF
568
569	IF (is_root_prc) THEN
570	CALL restget &
571	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
572	temp_g, MY_OPERATOR, nbindex, ijndex)
573	ENDIF
574	CALL scatter(temp_g,var)
575	DEALLOCATE(temp_g)
576	END SUBROUTINE restget_p_opp_r2d
577
578	!! =============================================================================================================================
579	!! SUBROUTINE: restget_p_opp_r2d
580	!!
581	!>\BRIEF Transform the data (real 2D) from the restart file onto the model grid with the operation MY_OPERATOR
582	!!
583	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
584	!!
585	!! \n
586	!_ ==============================================================================================================================
587	SUBROUTINE restget_p_opp_r3d &
588	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
589	var, MY_OPERATOR, nbindex, ijndex)
590	IMPLICIT NONE
591	!-
592	INTEGER :: fid
593	CHARACTER(LEN=*) :: vname_q
594	INTEGER :: iim, jjm, llm, itau
595	LOGICAL def_beha
596	REAL :: var(:,:,:)
597	CHARACTER(LEN=*) :: MY_OPERATOR
598	INTEGER :: nbindex, ijndex(nbindex)
599	!-----------------------------
600	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
601
602	IF (is_root_prc) THEN
603	ALLOCATE( temp_g(iim,jjm,llm) )
604	ELSE
605	ALLOCATE( temp_g(1,1,1) )
606	ENDIF
607
608	IF (is_root_prc) THEN
609	CALL restget &
610	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
611	temp_g, MY_OPERATOR, nbindex, ijndex)
612	ENDIF
613	CALL scatter(temp_g,var)
614	DEALLOCATE(temp_g)
615
616	END SUBROUTINE restget_p_opp_r3d
617
618	!! =============================================================================================================================
619	!! SUBROUTINE: restget_p_opp_r4d
620	!!
621	!>\BRIEF Transform the data (real 4D) from the restart file onto the model grid with the operation MY_OPERATOR
622	!!
623	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
624	!!
625	!! \n
626	!_ ==============================================================================================================================
627	SUBROUTINE restget_p_opp_r4d &
628	(fid, vname_q, iim, jjm, llm, zzm, itau, def_beha, &
629	var, MY_OPERATOR, nbindex, ijndex)
630	IMPLICIT NONE
631	!-
632	INTEGER :: fid
633	CHARACTER(LEN=*) :: vname_q
634	INTEGER :: iim, jjm, llm, zzm, itau
635	LOGICAL def_beha
636	REAL :: var(:,:,:,:)
637	CHARACTER(LEN=*) :: MY_OPERATOR
638	INTEGER :: nbindex, ijndex(nbindex)
639	!-----------------------------
640	REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: temp_g
641
642	IF (is_root_prc) THEN
643	ALLOCATE( temp_g(iim,jjm,llm,zzm) )
644	ELSE
645	ALLOCATE( temp_g(1,1,1,1) )
646	ENDIF
647
648	IF (is_root_prc) THEN
649	CALL restget &
650	(fid, vname_q, iim, jjm, llm, zzm, itau, def_beha, &
651	temp_g, MY_OPERATOR, nbindex, ijndex)
652	ENDIF
653	CALL scatter(temp_g,var)
654	DEALLOCATE(temp_g)
655
656	END SUBROUTINE restget_p_opp_r4d
657
658	!! =============================================================================================================================
659	!! SUBROUTINE: restget_p_opp_r5d
660	!!
661	!>\BRIEF Transform the data (real 5D) from the restart file onto the model grid with the operation MY_OPERATOR
662	!!
663	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
664	!!
665	!! \n
666	!_ ==============================================================================================================================
667	SUBROUTINE restget_p_opp_r5d &
668	(fid, vname_q, iim, jjm, llm, zzm, wwm, itau, def_beha, &
669	var, MY_OPERATOR, nbindex, ijndex)
670	IMPLICIT NONE
671	!-
672	INTEGER :: fid
673	CHARACTER(LEN=*) :: vname_q
674	INTEGER :: iim, jjm, llm, zzm, wwm, itau
675	LOGICAL def_beha
676	REAL :: var(:,:,:,:,:)
677	CHARACTER(LEN=*) :: MY_OPERATOR
678	INTEGER :: nbindex, ijndex(nbindex)
679	!-----------------------------
680	REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: temp_g
681
682	IF (is_root_prc) THEN
683	ALLOCATE( temp_g(iim,jjm,llm,zzm,wwm) )
684	ELSE
685	ALLOCATE( temp_g(1,1,1,1,1) )
686	ENDIF
687
688	IF (is_root_prc) THEN
689	CALL restget &
690	(fid, vname_q, iim, jjm, llm, zzm, wwm, itau, def_beha, &
691	temp_g, MY_OPERATOR, nbindex, ijndex)
692	ENDIF
693	CALL scatter(temp_g,var)
694	DEALLOCATE(temp_g)
695
696	END SUBROUTINE restget_p_opp_r5d
697
698	!! =============================================================================================================================
699	!! SUBROUTINE: restget_p_opp_i1d
700	!!
701	!>\BRIEF Transform the data (integer 1D) from the restart file onto the model grid with the operation MY_OPERATOR
702	!!
703	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
704	!!
705	!! \n
706	!_ ==============================================================================================================================
707	SUBROUTINE restget_p_opp_i1d &
708	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
709	var, MY_OPERATOR, nbindex, ijndex)
710	IMPLICIT NONE
711	!-
712	INTEGER :: fid
713	CHARACTER(LEN=*) :: vname_q
714	INTEGER :: iim, jjm, llm, itau
715	LOGICAL def_beha
716	INTEGER, INTENT(out) :: var(:)
717	CHARACTER(LEN=*) :: MY_OPERATOR
718	INTEGER :: nbindex, ijndex(nbindex)
719	!-----------------------------
720	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
721	INTEGER :: ier
722
723	ALLOCATE( temp_g(SIZE(var, DIM=1)), stat=ier )
724	IF (ier /= 0) CALL ipslerr_p(3, 'restget_p_opp_i1d', 'Memory allocation error', vname_q, '')
725
726	CALL restget_p &
727	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
728	temp_g, MY_OPERATOR, nbindex, ijndex)
729	var = INT(temp_g, i_std)
730
731	DEALLOCATE(temp_g)
732	END SUBROUTINE restget_p_opp_i1d
733
734	!! =============================================================================================================================
735	!! SUBROUTINE: restget_p_opp_i2d
736	!!
737	!>\BRIEF Transform the data (integer 2D) from the restart file onto the model grid with the operation MY_OPERATOR
738	!!
739	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
740	!!
741	!! \n
742	!_ ==============================================================================================================================
743	SUBROUTINE restget_p_opp_i2d &
744	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
745	var, MY_OPERATOR, nbindex, ijndex)
746	IMPLICIT NONE
747	!-
748	INTEGER :: fid
749	CHARACTER(LEN=*) :: vname_q
750	INTEGER :: iim, jjm, llm, itau
751	LOGICAL def_beha
752	INTEGER, INTENT(out) :: var(:,:)
753	CHARACTER(LEN=*) :: MY_OPERATOR
754	INTEGER :: nbindex, ijndex(nbindex)
755	!-----------------------------
756	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
757	INTEGER :: ier
758
759	ALLOCATE( temp_g(SIZE(var, DIM=1), SIZE(var, DIM=2)), stat=ier )
760	IF (ier /= 0) CALL ipslerr_p(3, 'restget_p_opp_i2d', 'Memory allocation error', vname_q, '')
761
762	CALL restget_p &
763	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
764	temp_g, MY_OPERATOR, nbindex, ijndex)
765	var = INT(temp_g, i_std)
766
767	DEALLOCATE(temp_g)
768	END SUBROUTINE restget_p_opp_i2d
769
770	!! =============================================================================================================================
771	!! SUBROUTINE: restget_p_opp_i3d
772	!!
773	!>\BRIEF Transform the data (integer 3D) from the restart file onto the model grid with the operation MY_OPERATOR
774	!!
775	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
776	!!
777	!! \n
778	!_ ==============================================================================================================================
779	SUBROUTINE restget_p_opp_i3d &
780	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
781	var, MY_OPERATOR, nbindex, ijndex)
782	IMPLICIT NONE
783	!-
784	INTEGER :: fid
785	CHARACTER(LEN=*) :: vname_q
786	INTEGER :: iim, jjm, llm, itau
787	LOGICAL def_beha
788	INTEGER, INTENT(out) :: var(:,:,:)
789	CHARACTER(LEN=*) :: MY_OPERATOR
790	INTEGER :: nbindex, ijndex(nbindex)
791	!-----------------------------
792	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
793	INTEGER :: ier
794
795	ALLOCATE( temp_g(SIZE(var, DIM=1), SIZE(var, DIM=2), SIZE(var, DIM=3)), stat=ier )
796	IF (ier /= 0) CALL ipslerr_p(3, 'restget_p_opp_i3d', 'Memory allocation error', vname_q, '')
797
798	CALL restget_p &
799	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
800	temp_g, MY_OPERATOR, nbindex, ijndex)
801	var = INT(temp_g, i_std)
802
803	DEALLOCATE(temp_g)
804	END SUBROUTINE restget_p_opp_i3d
805
806	!! =============================================================================================================================
807	!! SUBROUTINE: restget_p_opp_i4d
808	!!
809	!>\BRIEF Transform the data (integer 4D) from the restart file onto the model grid with the operation MY_OPERATOR
810	!!
811	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
812	!!
813	!! \n
814	!_ ==============================================================================================================================
815	SUBROUTINE restget_p_opp_i4d &
816	(fid, vname_q, iim, jjm, llm, mmm, itau, def_beha, &
817	var, MY_OPERATOR, nbindex, ijndex)
818	IMPLICIT NONE
819	!-
820	INTEGER :: fid
821	CHARACTER(LEN=*) :: vname_q
822	INTEGER :: iim, jjm, llm, mmm, itau
823	LOGICAL def_beha
824	INTEGER, INTENT(out) :: var(:,:,:,:)
825	CHARACTER(LEN=*) :: MY_OPERATOR
826	INTEGER :: nbindex, ijndex(nbindex)
827	!-----------------------------
828	REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: temp_g
829	INTEGER :: ier
830
831	ALLOCATE( temp_g(SIZE(var, DIM=1), SIZE(var, DIM=2), SIZE(var, DIM=3), SIZE(var, DIM=4)), stat=ier )
832	IF (ier /= 0) CALL ipslerr_p(3, 'restget_p_opp_i4d', 'Memory allocation error', vname_q, '')
833
834	CALL restget_p &
835	(fid, vname_q, iim, jjm, llm, mmm, itau, def_beha, &
836	temp_g, MY_OPERATOR, nbindex, ijndex)
837	var = INT(temp_g, i_std)
838
839	DEALLOCATE(temp_g)
840	END SUBROUTINE restget_p_opp_i4d
841
842	!! =============================================================================================================================
843	!! SUBROUTINE: restget_p_opp_i2d
844	!!
845	!>\BRIEF Transform the data (integer 5D) from the restart file onto the model grid with the operation MY_OPERATOR
846	!!
847	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
848	!!
849	!! \n
850	!_ ==============================================================================================================================
851	SUBROUTINE restget_p_opp_i5d &
852	(fid, vname_q, iim, jjm, llm, mmm, wwm, itau, def_beha, &
853	var, MY_OPERATOR, nbindex, ijndex)
854	IMPLICIT NONE
855	!-
856	INTEGER :: fid
857	CHARACTER(LEN=*) :: vname_q
858	INTEGER :: iim, jjm, llm, mmm, wwm, itau
859	LOGICAL def_beha
860	INTEGER, INTENT(out) :: var(:,:,:,:,:)
861	CHARACTER(LEN=*) :: MY_OPERATOR
862	INTEGER :: nbindex, ijndex(nbindex)
863	!-----------------------------
864	REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: temp_g
865	INTEGER :: ier
866
867	ALLOCATE( temp_g(SIZE(var, DIM=1), SIZE(var, DIM=2), SIZE(var, DIM=3), SIZE(var, DIM=4), SIZE(var, DIM=5)), stat=ier )
868	IF (ier /= 0) CALL ipslerr_p(3, 'restget_p_opp_i5d', 'Memory allocation error', vname_q, '')
869
870	CALL restget_p &
871	(fid, vname_q, iim, jjm, llm, mmm, wwm, itau, def_beha, &
872	temp_g, MY_OPERATOR, nbindex, ijndex)
873	var = INT(temp_g, i_std)
874
875	DEALLOCATE(temp_g)
876	END SUBROUTINE restget_p_opp_i5d
877
878	!! =============================================================================================================================
879	!! SUBROUTINE: restget_p_r1d
880	!!
881	!>\BRIEF Transform the data (real 1D) from the restart file onto the model grid
882	!!
883	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
884	!! \n
885	!_ ==============================================================================================================================
886	SUBROUTINE restget_p_r1d &
887	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
888	! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
889	IMPLICIT NONE
890	!-
891	INTEGER :: fid
892	CHARACTER(LEN=*) :: vname_q
893	INTEGER :: iim, jjm, llm, itau
894	LOGICAL :: def_beha
895	REAL :: var(:)
896	!-------------------------
897	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
898
899	IF (is_root_prc) THEN
900	ALLOCATE( temp_g(iimjjmllm) )
901	ELSE
902	ALLOCATE( temp_g(1) )
903	ENDIF
904
905	IF (is_root_prc) THEN
906	CALL restget &
907	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
908	ENDIF
909	CALL scatter2D_mpi(temp_g,var)
910	DEALLOCATE(temp_g)
911	END SUBROUTINE restget_p_r1d
912
913	!! =============================================================================================================================
914	!! SUBROUTINE: restget_p_r2d
915	!!
916	!>\BRIEF Transform the data (real 2D) from the restart file onto the model grid
917	!!
918	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
919	!! \n
920	!_ ==============================================================================================================================
921	SUBROUTINE restget_p_r2d &
922	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
923	IMPLICIT NONE
924	!-
925	INTEGER :: fid
926	CHARACTER(LEN=*) :: vname_q
927	INTEGER :: iim, jjm, llm, itau
928	LOGICAL :: def_beha
929	REAL :: var(:,:)
930	!-------------------------
931	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
932
933	IF (is_root_prc) THEN
934	ALLOCATE( temp_g(iim,jjm) )
935	ELSE
936	ALLOCATE( temp_g(1,1) )
937	ENDIF
938	IF (is_root_prc) THEN
939	CALL restget &
940	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
941	ENDIF
942	CALL scatter2D_mpi(temp_g,var)
943	DEALLOCATE(temp_g)
944	END SUBROUTINE restget_p_r2d
945
946	!! =============================================================================================================================
947	!! SUBROUTINE: restget_p_r3d
948	!!
949	!>\BRIEF Transform the data (real 3D) from the restart file onto the model grid
950	!!
951	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
952	!! \n
953	!_ ==============================================================================================================================
954	SUBROUTINE restget_p_r3d &
955	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
956	IMPLICIT NONE
957	!-
958	INTEGER :: fid
959	CHARACTER(LEN=*) :: vname_q
960	INTEGER :: iim, jjm, llm, itau
961	LOGICAL def_beha
962	REAL :: var(:,:,:)
963	!-------------------------
964	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
965
966	IF (is_root_prc) THEN
967	ALLOCATE( temp_g(iim,jjm,llm) )
968	ELSE
969	ALLOCATE( temp_g(1,1,1) )
970	ENDIF
971
972	IF (is_root_prc) THEN
973	CALL restget &
974	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
975	ENDIF
976	CALL scatter2D_mpi(temp_g,var)
977	DEALLOCATE(temp_g)
978	END SUBROUTINE restget_p_r3d
979
980	!! =============================================================================================================================
981	!! SUBROUTINE: restget_p_nogrid_r1d
982	!!
983	!>\BRIEF Transform the data (real 1D) from the restart file onto the model grid
984	!!
985	!! DESCRIPTION:
986	!! \n
987	!_ ==============================================================================================================================
988	SUBROUTINE restget_p_nogrid_r1d &
989	(fid,vname_q,itau,def_beha,def_val,var)
990	!
991	IMPLICIT NONE
992	!-
993	INTEGER, INTENT(in) :: fid
994	CHARACTER(LEN=*), INTENT(in) :: vname_q
995	INTEGER, INTENT(in) :: itau
996	LOGICAL, INTENT(in) :: def_beha
997	REAL, INTENT(in) :: def_val
998	REAL, DIMENSION(:), INTENT(out) :: var
999	!-------------------------
1000	IF (is_root_prc) THEN
1001	var = val_exp
1002	CALL restget (fid, vname_q, 1 ,1 , 1, itau, def_beha, var)
1003	IF(ALL(var == val_exp)) var = def_val
1004	ENDIF
1005	CALL bcast(var)
1006
1007	END SUBROUTINE restget_p_nogrid_r1d
1008
1009	!! =============================================================================================================================
1010	!! SUBROUTINE: restget_p_nogrid_r_scal
1011	!!
1012	!>\BRIEF Transform the data (real scalar) from the restart file onto the model grid
1013	!!
1014	!! DESCRIPTION:
1015	!! \n
1016	!_ ==============================================================================================================================
1017	SUBROUTINE restget_p_nogrid_r_scal &
1018	(fid,vname_q,itau,def_beha,def_val,var)
1019	!
1020	IMPLICIT NONE
1021	!-
1022	INTEGER, INTENT(in) :: fid
1023	CHARACTER(LEN=*), INTENT(in) :: vname_q
1024	INTEGER, INTENT(in) :: itau
1025	LOGICAL, INTENT(in) :: def_beha
1026	REAL, INTENT(in) :: def_val
1027	REAL, INTENT(out) :: var
1028	!-------------------------
1029	REAL, DIMENSION(1) :: tmp
1030
1031	tmp(1) = var
1032	IF (is_root_prc) THEN
1033	var = val_exp
1034	CALL restget (fid, vname_q, 1 ,1 , 1, itau, def_beha, tmp)
1035	var = tmp(1)
1036	IF(var == val_exp) var = def_val
1037	ENDIF
1038	CALL bcast(var)
1039
1040	END SUBROUTINE restget_p_nogrid_r_scal
1041
1042	!! =============================================================================================================================
1043	!! SUBROUTINE: restget_p_nogrid_i_scal
1044	!!
1045	!>\BRIEF Transform the data (integer scalar) from the restart file onto the model grid
1046	!!
1047	!! DESCRIPTION:
1048	!! \n
1049	!_ ==============================================================================================================================
1050	SUBROUTINE restget_p_nogrid_i_scal &
1051	(fid,vname_q,itau,def_beha,def_val,varint)
1052	!
1053	IMPLICIT NONE
1054	!-
1055	INTEGER, INTENT(in) :: fid
1056	CHARACTER(LEN=*), INTENT(in) :: vname_q
1057	INTEGER, INTENT(in) :: itau
1058	LOGICAL, INTENT(in) :: def_beha
1059	REAL, INTENT(in) :: def_val
1060	INTEGER, INTENT(out) :: varint
1061	!-------------------------
1062	REAL :: tmp
1063
1064	CALL restget_p_nogrid_r_scal(fid, vname_q, itau, def_beha, def_val, tmp)
1065	varint = INT(tmp)
1066	END SUBROUTINE restget_p_nogrid_i_scal
1067
1068	!! =============================================================================================================================
1069	!! SUBROUTINE: restput_p_opp_r1d
1070	!!
1071	!>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file with the operation MY_OPERATOR
1072	!!
1073	!! DESCRIPTION: Need to be call by all process
1074	!! \n
1075	!_ ==============================================================================================================================
1076	SUBROUTINE restput_p_opp_r1d &
1077	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
1078	IMPLICIT NONE
1079	!-
1080	INTEGER :: fid
1081	CHARACTER(LEN=*) :: vname_q
1082	INTEGER :: iim, jjm, llm, itau
1083	REAL :: var(:)
1084	CHARACTER(LEN=*) :: MY_OPERATOR
1085	INTEGER :: nbindex, ijndex(nbindex)
1086	!-----------------------------
1087	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
1088
1089	IF (is_root_prc) THEN
1090	ALLOCATE( temp_g(iimjjmllm) )
1091	ELSE
1092	ALLOCATE ( temp_g(1) )
1093	ENDIF
1094
1095	CALL gather(var,temp_g)
1096	IF (is_root_prc) THEN
1097	CALL restput &
1098	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
1099	ENDIF
1100
1101	DEALLOCATE( temp_g )
1102
1103	END SUBROUTINE restput_p_opp_r1d
1104
1105	!! =============================================================================================================================
1106	!! SUBROUTINE: restput_p_opp_r2d
1107	!!
1108	!>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file with the operation MY_OPERATOR
1109	!!
1110	!! DESCRIPTION: Need to be call by all process
1111	!! \n
1112	!_ ==============================================================================================================================
1113	SUBROUTINE restput_p_opp_r2d &
1114	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
1115	IMPLICIT NONE
1116	!-
1117	INTEGER :: fid
1118	CHARACTER(LEN=*) :: vname_q
1119	INTEGER :: iim, jjm, llm, itau
1120	REAL :: var(:,:)
1121	CHARACTER(LEN=*) :: MY_OPERATOR
1122	INTEGER :: nbindex, ijndex(nbindex)
1123	!-----------------------------
1124	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
1125
1126	IF (is_root_prc) THEN
1127	ALLOCATE( temp_g(iim,jjm) )
1128	ELSE
1129	ALLOCATE( temp_g(1,1) )
1130	ENDIF
1131
1132	CALL gather(var,temp_g)
1133	IF (is_root_prc) THEN
1134	CALL restput &
1135	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
1136	ENDIF
1137	DEALLOCATE( temp_g )
1138
1139	END SUBROUTINE restput_p_opp_r2d
1140
1141	!! =============================================================================================================================
1142	!! SUBROUTINE: restput_p_opp_r3d
1143	!!
1144	!>\BRIEF allows to re-index data (real 3D) onto the original grid of the restart file with the operation MY_OPERATOR
1145	!!
1146	!! DESCRIPTION: Need to be call by all process
1147	!! \n
1148	!_ ==============================================================================================================================
1149	SUBROUTINE restput_p_opp_r3d &
1150	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
1151	IMPLICIT NONE
1152	!-
1153	INTEGER :: fid
1154	CHARACTER(LEN=*) :: vname_q
1155	INTEGER :: iim, jjm, llm, itau
1156	REAL :: var(:,:,:)
1157	CHARACTER(LEN=*) :: MY_OPERATOR
1158	INTEGER :: nbindex, ijndex(nbindex)
1159	!-----------------------------
1160	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
1161
1162	IF (is_root_prc) THEN
1163	ALLOCATE( temp_g(iim,jjm,llm) )
1164	ELSE
1165	ALLOCATE( temp_g(1,1,1) )
1166	ENDIF
1167
1168	CALL gather(var,temp_g)
1169	IF (is_root_prc) THEN
1170	CALL restput &
1171	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
1172	ENDIF
1173	DEALLOCATE( temp_g )
1174
1175
1176	END SUBROUTINE restput_p_opp_r3d
1177
1178	!! =============================================================================================================================
1179	!! SUBROUTINE: restput_p_opp_r4d
1180	!!
1181	!>\BRIEF allows to re-index data (real 4D) onto the original grid of the restart file with the operation MY_OPERATOR
1182	!!
1183	!! DESCRIPTION: Need to be call by all process
1184	!! \n
1185	!_ ==============================================================================================================================
1186	SUBROUTINE restput_p_opp_r4d &
1187	(fid, vname_q, iim, jjm, llm, zzm, itau, var, MY_OPERATOR, nbindex, ijndex)
1188	IMPLICIT NONE
1189	!-
1190	INTEGER :: fid
1191	CHARACTER(LEN=*) :: vname_q
1192	INTEGER :: iim, jjm, llm, zzm, itau
1193	REAL :: var(:,:,:,:)
1194	CHARACTER(LEN=*) :: MY_OPERATOR
1195	INTEGER :: nbindex, ijndex(nbindex)
1196	!-----------------------------
1197	REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: temp_g
1198
1199	IF (is_root_prc) THEN
1200	ALLOCATE( temp_g(iim,jjm,llm,zzm) )
1201	ELSE
1202	ALLOCATE( temp_g(1,1,1,1) )
1203	ENDIF
1204
1205	CALL gather(var,temp_g)
1206	IF (is_root_prc) THEN
1207	CALL restput &
1208	(fid, vname_q, iim, jjm, llm, zzm, itau, &
1209	temp_g, MY_OPERATOR, nbindex, ijndex)
1210	ENDIF
1211	DEALLOCATE( temp_g )
1212
1213
1214	END SUBROUTINE restput_p_opp_r4d
1215
1216	!! =============================================================================================================================
1217	!! SUBROUTINE: restput_p_opp_r5d
1218	!!
1219	!>\BRIEF allows to re-index data (real 5D) onto the original grid of the restart file with the operation MY_OPERATOR
1220	!!
1221	!! DESCRIPTION: Need to be call by all process
1222	!! \n
1223	!_ ==============================================================================================================================
1224	SUBROUTINE restput_p_opp_r5d &
1225	(fid, vname_q, iim, jjm, llm, zzm, wwm, itau, var, MY_OPERATOR, nbindex, ijndex)
1226	IMPLICIT NONE
1227	!-
1228	INTEGER :: fid
1229	CHARACTER(LEN=*) :: vname_q
1230	INTEGER :: iim, jjm, llm, zzm, wwm, itau
1231	REAL :: var(:,:,:,:,:)
1232	CHARACTER(LEN=*) :: MY_OPERATOR
1233	INTEGER :: nbindex, ijndex(nbindex)
1234	!-----------------------------
1235	REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: temp_g
1236
1237	IF (is_root_prc) THEN
1238	ALLOCATE( temp_g(iim,jjm,llm,zzm,wwm) )
1239	ELSE
1240	ALLOCATE( temp_g(1,1,1,1,1) )
1241	ENDIF
1242
1243	CALL gather(var,temp_g)
1244	IF (is_root_prc) THEN
1245	CALL restput &
1246	(fid, vname_q, iim, jjm, llm, zzm, wwm, itau, &
1247	temp_g, MY_OPERATOR, nbindex, ijndex)
1248	ENDIF
1249	DEALLOCATE( temp_g )
1250
1251
1252	END SUBROUTINE restput_p_opp_r5d
1253
1254	!! =============================================================================================================================
1255	!! SUBROUTINE: restput_p_opp_i1d
1256	!!
1257	!>\BRIEF allows to re-index data (integer 2D) onto the original grid of the restart file with the operation MY_OPERATOR
1258	!!
1259	!! DESCRIPTION: Need to be call by all process
1260	!! \n
1261	!_ ==============================================================================================================================
1262	SUBROUTINE restput_p_opp_i1d &
1263	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
1264	IMPLICIT NONE
1265	!-
1266	INTEGER :: fid
1267	CHARACTER(LEN=*) :: vname_q
1268	INTEGER :: iim, jjm, llm, itau
1269	INTEGER :: var(:)
1270	CHARACTER(LEN=*) :: MY_OPERATOR
1271	INTEGER :: nbindex, ijndex(nbindex)
1272	!-----------------------------
1273	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
1274	INTEGER :: ier
1275
1276	ALLOCATE( temp_g(SIZE(var, DIM=1)), stat=ier)
1277	IF (ier /= 0) CALL ipslerr_p(3, 'restput_p_opp_i1d', 'Allocation memory error ', vname_q, '')
1278
1279	temp_g = REAL(var, r_std)
1280	CALL restput_p &
1281	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
1282
1283	DEALLOCATE( temp_g )
1284
1285	END SUBROUTINE restput_p_opp_i1d
1286
1287	!! =============================================================================================================================
1288	!! SUBROUTINE: restput_p_opp_i2d
1289	!!
1290	!>\BRIEF allows to re-index data (integer 2D) onto the original grid of the restart file with the operation MY_OPERATOR
1291	!!
1292	!! DESCRIPTION: Need to be call by all process
1293	!! \n
1294	!_ ==============================================================================================================================
1295	SUBROUTINE restput_p_opp_i2d &
1296	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
1297	IMPLICIT NONE
1298	!-
1299	INTEGER :: fid
1300	CHARACTER(LEN=*) :: vname_q
1301	INTEGER :: iim, jjm, llm, itau
1302	INTEGER :: var(:,:)
1303	CHARACTER(LEN=*) :: MY_OPERATOR
1304	INTEGER :: nbindex, ijndex(nbindex)
1305	!-----------------------------
1306	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
1307	INTEGER :: ier
1308
1309	ALLOCATE( temp_g(SIZE(var, DIM=1), SIZE(var, DIM=2)), stat=ier)
1310	IF (ier /= 0) CALL ipslerr_p(3, 'restput_p_opp_i2d', 'Allocation memory error', vname_q, '')
1311
1312	temp_g = REAL(var, r_std)
1313	CALL restput_p &
1314	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
1315
1316	DEALLOCATE( temp_g )
1317
1318	END SUBROUTINE restput_p_opp_i2d
1319
1320	!! =============================================================================================================================
1321	!! SUBROUTINE: restput_p_opp_i3d
1322	!!
1323	!>\BRIEF allows to re-index data (integer 3D) onto the original grid of the restart file with the operation MY_OPERATOR
1324	!!
1325	!! DESCRIPTION: Need to be call by all process
1326	!! \n
1327	!_ ==============================================================================================================================
1328	SUBROUTINE restput_p_opp_i3d &
1329	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
1330	IMPLICIT NONE
1331	!-
1332	INTEGER :: fid
1333	CHARACTER(LEN=*) :: vname_q
1334	INTEGER :: iim, jjm, llm, itau
1335	INTEGER :: var(:,:,:)
1336	CHARACTER(LEN=*) :: MY_OPERATOR
1337	INTEGER :: nbindex, ijndex(nbindex)
1338	!-----------------------------
1339	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
1340	INTEGER :: ier
1341
1342	ALLOCATE( temp_g(SIZE(var, DIM=1), SIZE(var, DIM=2), SIZE(var, DIM=3)), stat=ier)
1343	IF (ier /= 0) CALL ipslerr_p(3, 'restput_p_opp_i2d', 'Allocation memory error', vname_q, '')
1344
1345	temp_g = REAL(var, r_std)
1346	CALL restput_p &
1347	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
1348
1349	DEALLOCATE( temp_g )
1350
1351	END SUBROUTINE restput_p_opp_i3d
1352
1353	!! =============================================================================================================================
1354	!! SUBROUTINE: restput_p_opp_i4d
1355	!!
1356	!>\BRIEF allows to re-index data (integer 4D) onto the original grid of the restart file with the operation MY_OPERATOR
1357	!!
1358	!! DESCRIPTION: Need to be call by all process
1359	!! \n
1360	!_ ==============================================================================================================================
1361	SUBROUTINE restput_p_opp_i4d &
1362	(fid, vname_q, iim, jjm, llm, mmm, itau, var, MY_OPERATOR, nbindex, ijndex)
1363	IMPLICIT NONE
1364	!-
1365	INTEGER :: fid
1366	CHARACTER(LEN=*) :: vname_q
1367	INTEGER :: iim, jjm, llm, mmm, itau
1368	INTEGER :: var(:,:,:,:)
1369	CHARACTER(LEN=*) :: MY_OPERATOR
1370	INTEGER :: nbindex, ijndex(nbindex)
1371	!-----------------------------
1372	REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: temp_g
1373	INTEGER :: ier
1374
1375	ALLOCATE( temp_g(SIZE(var, DIM=1), SIZE(var, DIM=2), SIZE(var, DIM=3), SIZE(var, DIM=4)), stat=ier)
1376	IF (ier /= 0) CALL ipslerr_p(3, 'restput_p_opp_i4d', 'Allocation memory error', vname_q, '')
1377
1378	temp_g = REAL(var, r_std)
1379	CALL restput_p &
1380	(fid, vname_q, iim, jjm, llm, mmm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
1381
1382	DEALLOCATE( temp_g )
1383
1384	END SUBROUTINE restput_p_opp_i4d
1385
1386	!! =============================================================================================================================
1387	!! SUBROUTINE: restput_p_opp_i5d
1388	!!
1389	!>\BRIEF allows to re-index data (integer 5D) onto the original grid of the restart file with the operation MY_OPERATOR
1390	!!
1391	!! DESCRIPTION: Need to be call by all process
1392	!! \n
1393	!_ ==============================================================================================================================
1394	SUBROUTINE restput_p_opp_i5d &
1395	(fid, vname_q, iim, jjm, llm, mmm, zzm, itau, var, MY_OPERATOR, nbindex, ijndex)
1396	IMPLICIT NONE
1397	!-
1398	INTEGER :: fid
1399	CHARACTER(LEN=*) :: vname_q
1400	INTEGER :: iim, jjm, llm, mmm, zzm, itau
1401	INTEGER :: var(:,:,:,:,:)
1402	CHARACTER(LEN=*) :: MY_OPERATOR
1403	INTEGER :: nbindex, ijndex(nbindex)
1404	!-----------------------------
1405	REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: temp_g
1406	INTEGER :: ier
1407
1408	ALLOCATE( temp_g(SIZE(var, DIM=1), SIZE(var, DIM=2), SIZE(var, DIM=3), &
1409	SIZE(var, DIM=4), SIZE(var, DIM=5)), stat=ier)
1410	IF (ier /= 0) CALL ipslerr_p(3, 'restput_p_opp_i5d', 'Allocation memory error', vname_q, '')
1411
1412	temp_g = REAL(var, r_std)
1413	CALL restput_p &
1414	(fid, vname_q, iim, jjm, llm, mmm, zzm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
1415
1416	DEALLOCATE( temp_g )
1417
1418	END SUBROUTINE restput_p_opp_i5d
1419
1420	!! =============================================================================================================================
1421	!! SUBROUTINE: restput_p_r1d
1422	!!
1423	!>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file
1424	!!
1425	!! DESCRIPTION: Need to be call by all process
1426	!!
1427	!! \n
1428	!_ ==============================================================================================================================
1429	SUBROUTINE restput_p_r1d (fid,vname_q,iim,jjm,llm,itau,var)
1430	IMPLICIT NONE
1431	!-
1432	INTEGER :: fid
1433	CHARACTER(LEN=*) :: vname_q
1434	INTEGER :: iim, jjm, llm, itau
1435	REAL :: var(:)
1436	!-----------------------------
1437	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
1438
1439	IF (is_root_prc) THEN
1440	ALLOCATE( temp_g(iimjjmllm) )
1441	ELSE
1442	ALLOCATE( temp_g(1) )
1443	ENDIF
1444
1445	CALL gather2D_mpi(var,temp_g)
1446	IF (is_root_prc) THEN
1447	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
1448	ENDIF
1449	DEALLOCATE( temp_g )
1450
1451	END SUBROUTINE restput_p_r1d
1452
1453	!! =============================================================================================================================
1454	!! SUBROUTINE: restput_p_r2d
1455	!!
1456	!>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file
1457	!!
1458	!! DESCRIPTION: Need to be call by all process
1459	!!
1460	!! \n
1461	!_ ==============================================================================================================================
1462	SUBROUTINE restput_p_r2d (fid,vname_q,iim,jjm,llm,itau,var)
1463	IMPLICIT NONE
1464	!-
1465	INTEGER :: fid
1466	CHARACTER(LEN=*) :: vname_q
1467	INTEGER :: iim, jjm, llm, itau
1468	REAL :: var(:,:)
1469	!-------------------------
1470	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
1471
1472	IF (is_root_prc) THEN
1473	ALLOCATE( temp_g(iim,jjm) )
1474	ELSE
1475	ALLOCATE( temp_g(1,1) )
1476	ENDIF
1477
1478	CALL gather2D_mpi(var,temp_g)
1479	IF (is_root_prc) THEN
1480	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
1481	ENDIF
1482	DEALLOCATE( temp_g )
1483
1484	END SUBROUTINE restput_p_r2d
1485
1486	!! =============================================================================================================================
1487	!! SUBROUTINE: restput_p_nogrid_r1d
1488	!!
1489	!>\BRIEF save reald 1D array (non-grid) data into the restart file
1490	!!
1491	!! DESCRIPTION: Need to be call by all process
1492	!!
1493	!! \n
1494	!_ ==============================================================================================================================
1495	SUBROUTINE restput_p_nogrid_r1d (fid,vname_q,itau,var)
1496	IMPLICIT NONE
1497	!-
1498	INTEGER :: fid
1499	CHARACTER(LEN=*) :: vname_q
1500	INTEGER :: itau
1501	REAL,DIMENSION(:) :: var
1502	!-----------------------------
1503
1504	IF (is_root_prc) THEN
1505	CALL restput (fid, vname_q, 1, 1, 1, itau, var)
1506	ENDIF
1507
1508	END SUBROUTINE restput_p_nogrid_r1d
1509
1510	!! =============================================================================================================================
1511	!! SUBROUTINE: restput_p_r3d
1512	!!
1513	!>\BRIEF allows to re-index data (real 3D) onto the original grid of the restart file
1514	!!
1515	!! DESCRIPTION: Need to be call by all process
1516	!!
1517	!! \n
1518	!_ ==============================================================================================================================
1519	SUBROUTINE restput_p_r3d (fid,vname_q,iim,jjm,llm,itau,var)
1520	IMPLICIT NONE
1521	!-
1522	INTEGER :: fid
1523	CHARACTER(LEN=*) :: vname_q
1524	INTEGER :: iim, jjm, llm, itau
1525	REAL :: var(:,:,:)
1526	!-------------------------
1527	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
1528
1529	IF (is_root_prc) THEN
1530	ALLOCATE( temp_g(iim,jjm,llm) )
1531	ELSE
1532	ALLOCATE( temp_g(1,1,1) )
1533	ENDIF
1534
1535	CALL gather2D_mpi(var,temp_g)
1536	IF (is_root_prc) THEN
1537	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
1538	ENDIF
1539	DEALLOCATE( temp_g )
1540
1541	END SUBROUTINE restput_p_r3d
1542
1543	!! =============================================================================================================================
1544	!! SUBROUTINE: restput_p_nogrid_r_scal
1545	!!
1546	!>\BRIEF save real scalar (non-grid) data into the restart file
1547	!!
1548	!! DESCRIPTION: Need to be call by all process
1549	!!
1550	!! \n
1551	!_ ==============================================================================================================================
1552	SUBROUTINE restput_p_nogrid_r_scal (fid,vname_q,itau,var)
1553	IMPLICIT NONE
1554	!-
1555	INTEGER :: fid
1556	CHARACTER(LEN=*) :: vname_q
1557	INTEGER :: itau
1558	REAL :: var
1559	!-----------------------------
1560	REAL :: xtmp(1)
1561
1562	IF (is_root_prc) THEN
1563	xtmp(1) = var
1564	CALL restput (fid, vname_q, 1, 1, 1, itau, xtmp)
1565	ENDIF
1566
1567	END SUBROUTINE restput_p_nogrid_r_scal
1568
1569	!! =============================================================================================================================
1570	!! SUBROUTINE: restput_p_nogrid_i_scal
1571	!!
1572	!>\BRIEF save integer scalar (non-grid) data into the restart file
1573	!!
1574	!! DESCRIPTION: Need to be call by all process
1575	!!
1576	!! \n
1577	!_ ==============================================================================================================================
1578	SUBROUTINE restput_p_nogrid_i_scal (fid,vname_q,itau,var)
1579	IMPLICIT NONE
1580	!-
1581	INTEGER :: fid
1582	CHARACTER(LEN=*) :: vname_q
1583	INTEGER :: itau
1584	INTEGER :: var
1585	!-----------------------------
1586	REAL :: xtmp(1)
1587	REAL :: realvar
1588
1589	IF (is_root_prc) THEN
1590	realvar = REAL(var,r_std)
1591	xtmp(1) = realvar
1592	CALL restput (fid, vname_q, 1, 1, 1, itau, xtmp)
1593	ENDIF
1594
1595	END SUBROUTINE restput_p_nogrid_i_scal
1596
1597	!! =============================================================================================================================
1598	!! SUBROUTINE: histwrite_r1d_p
1599	!!
1600	!>\BRIEF give the data (real 1D) to the IOIPSL system (if we don't use XIOS).
1601	!!
1602	!! DESCRIPTION: Need to be call by all process
1603	!!
1604	!! \n
1605	!_ ==============================================================================================================================
1606	SUBROUTINE histwrite_r1d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
1607	IMPLICIT NONE
1608	!-
1609	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
1610	REAL,DIMENSION(:),INTENT(IN) :: pdata
1611	CHARACTER(LEN=*),INTENT(IN) :: pvarname
1612
1613	REAL,DIMENSION(nbp_mpi) :: pdata_mpi
1614
1615	IF (pfileid > 0) THEN
1616	! Continue only if the file is initilalized
1617	CALL gather_omp(pdata,pdata_mpi)
1618	IF (is_omp_root) THEN
1619	CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpi,kindex_mpi)
1620	ENDIF
1621	END IF
1622
1623	END SUBROUTINE histwrite_r1d_p
1624
1625	!! =============================================================================================================================
1626	!! SUBROUTINE: histwrite_r2d_p
1627	!!
1628	!>\BRIEF give the data (real 2D) to the IOIPSL system (if we don't use XIOS).
1629	!!
1630	!! DESCRIPTION: Need to be call by all process
1631	!!
1632	!! \n
1633	!_ ==============================================================================================================================
1634	SUBROUTINE histwrite_r2d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
1635	IMPLICIT NONE
1636	!-
1637	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
1638	REAL,DIMENSION(:,:),INTENT(IN) :: pdata
1639	CHARACTER(LEN=*),INTENT(IN) :: pvarname
1640
1641	IF (pfileid > 0) THEN
1642	! Continue only if the file is initilalized
1643	CALL body(size(pdata,2),nindex)
1644	END IF
1645
1646	CONTAINS
1647
1648	SUBROUTINE body(dim,nindex)
1649	INTEGER :: dim
1650	INTEGER :: nindex(nbp_omp,dim)
1651
1652	INTEGER :: nindex_mpi(nbp_mpi,dim)
1653	REAL :: pdata_mpi(nbp_mpi,dim)
1654
1655	CALL gather_omp(pdata,pdata_mpi)
1656	CALL gather_omp(nindex,nindex_mpi)
1657
1658	IF (is_omp_root) THEN
1659	CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpidim,reshape(nindex_mpi,(/nbp_mpidim/)))
1660	ENDIF
1661	END SUBROUTINE body
1662
1663	END SUBROUTINE histwrite_r2d_p
1664
1665	!! =============================================================================================================================
1666	!! SUBROUTINE: histwrite_r3d_p
1667	!!
1668	!>\BRIEF give the data (real 3D) to the IOIPSL system (if we don't use XIOS).
1669	!!
1670	!! DESCRIPTION: Need to be call by all process
1671	!!
1672	!! \n
1673	!_ ==============================================================================================================================
1674	SUBROUTINE histwrite_r3d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
1675	IMPLICIT NONE
1676	!-
1677	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
1678	REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata
1679	CHARACTER(LEN=*),INTENT(IN) :: pvarname
1680
1681	CHARACTER(LEN=10) :: part_str
1682	CHARACTER(LEN=LEN(part_str) + LEN(pvarname) + 1) :: var_name
1683	REAL,DIMENSION(SIZE(pdata, 1),SIZE(pdata, 2)) :: tmparr
1684	INTEGER :: jv
1685
1686	DO jv = 1, SIZE(pdata, 3)
1687	WRITE(part_str,'(I2)') jv
1688	IF (jv < 10) part_str(1:1) = '0'
1689	var_name = TRIM(pvarname)//'_'//part_str(1:LEN_TRIM(part_str))
1690	tmparr = pdata(:,:,jv)
1691	CALL histwrite_r2d_p(pfileid, var_name, pitau, tmparr, nbindex, nindex)
1692	ENDDO
1693
1694
1695	END SUBROUTINE histwrite_r3d_p
1696
1697
1698	END MODULE ioipsl_para

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

Context Navigation

source: branches/publications/ORCHIDEE_gmd_2018_MICT-LEAK/src_parallel/ioipsl_para.f90 @ 5558

Download in other formats: