Context Navigation

source: branches/publications/ORCHIDEE-ICE_SurfaceMassBalance/src_parallel/ioipsl_para.f90 @ 8398

Last change on this file since 8398 was 4264, checked in by josefine.ghattas, 7 years ago
Removed Author from svn information from module headings, according to coding guide lines.
Property svn:keywords set to `HeadURL Date Author Revision`
File size: 32.5 KB

Line
1	! ==============================================================================================================================
2	! MODULE : ioipls_para
3	!
4	! CONTACT : orchidee-help _at_ ipsl.jussieu.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	!-
49	IMPLICIT NONE
50
51	INTEGER, SAVE :: orch_domain_id
52	!-
53	INTEGER :: orch_ipslout=6, orch_ilv_cur=0, orch_ilv_max=0
54	!$OMP THREADPRIVATE( orch_ipslout, orch_ilv_cur, orch_ilv_max )
55
56	!-
57	!-
58	#include "src_parallel.h"
59	!-
60	!! ==============================================================================================================================
61	!! INTERFACE : getin_p
62	!!
63	!>\BRIEF interface to parallelize the call to getin in IOIPSL
64	!!
65	!! DESCRIPTION : get a variable from a text input file. Need to be call by all process
66	!!
67	!! \n
68	!_ ================================================================================================================================
69	INTERFACE getin_p
70	MODULE PROCEDURE getin_p_c,getin_p_c1, &
71	getin_p_i,getin_p_i1,getin_p_i2,&
72	getin_p_r,getin_p_r1,getin_p_r2,&
73	getin_p_l,getin_p_l1,getin_p_l2
74	END INTERFACE
75	!-
76	!! ==============================================================================================================================
77	!! INTERFACE : restput_p
78	!!
79	!>\BRIEF interface to parallelize the call to restput in IOIPSL
80	!!
81	!! DESCRIPTION : allows to re-index data onto the original grid of the restart file. Need to be call by all process
82	!!
83	!! \n
84	!_ ================================================================================================================================
85	INTERFACE restput_p
86	MODULE PROCEDURE &
87	restput_p_r3d, restput_p_r2d, restput_p_r1d, &
88	restput_p_opp_r2d, restput_p_opp_r1d
89	END INTERFACE
90	!-
91	!! ==============================================================================================================================
92	!! INTERFACE : restget_p
93	!!
94	!>\BRIEF interface to parallelize the call to restget in IOIPSL
95	!!
96	!! DESCRIPTION : Transform the data from the restart file onto the model grid.
97	!!
98	!! \n
99	!_ ================================================================================================================================
100	INTERFACE restget_p
101	MODULE PROCEDURE &
102	restget_p_r3d, restget_p_r2d, restget_p_r1d, &
103	restget_p_opp_r2d, restget_p_opp_r1d
104	END INTERFACE
105
106	!! ==============================================================================================================================
107	!! INTERFACE : histwrite_p
108	!!
109	!>\BRIEF interface to parallelize the call to histwrite in IOIPSL
110	!!
111	!! DESCRIPTION : give the data to the IOIPSL system (if we don't use XIOS). Need to be call by all process
112	!!
113	!! \n
114	!_ ================================================================================================================================
115
116	INTERFACE histwrite_p
117	MODULE PROCEDURE &
118	histwrite_r1d_p,histwrite_r2d_p,histwrite_r3d_p
119	END INTERFACE
120
121	CONTAINS
122
123
124	!! =============================================================================================================================
125	!! SUBROUTINE: Init_ioipsl_para
126	!!
127	!>\BRIEF call to IOIPSL routine : flio_dom_set
128	!!
129	!! DESCRIPTION: will sets up the domain activity of IOIPSL. Need to be call by all process
130	!!
131	!! \n
132	!_ ==============================================================================================================================
133
134	SUBROUTINE Init_ioipsl_para
135
136	IMPLICIT NONE
137
138	INTEGER,DIMENSION(2) :: ddid
139	INTEGER,DIMENSION(2) :: dsg
140	INTEGER,DIMENSION(2) :: dsl
141	INTEGER,DIMENSION(2) :: dpf
142	INTEGER,DIMENSION(2) :: dpl
143	INTEGER,DIMENSION(2) :: dhs
144	INTEGER,DIMENSION(2) :: dhe
145
146	IF (is_omp_root) THEN
147	ddid=(/ 1,2 /)
148	dsg=(/ iim_g, jjm_g /)
149	dsl=(/ iim_g, jj_nb /)
150	dpf=(/ 1,jj_begin /)
151	dpl=(/ iim_g, jj_end /)
152	dhs=(/ ii_begin-1,0 /)
153	if (mpi_rank==mpi_size-1) then
154	dhe=(/0,0/)
155	else
156	dhe=(/ iim_g-ii_end,0 /)
157	endif
158
159	call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
160	'APPLE',orch_domain_id)
161	ENDIF
162
163	END SUBROUTINE Init_ioipsl_para
164
165	!! =============================================================================================================================
166	!! SUBROUTINE: ioconf_setatt_p
167	!!
168	!>\BRIEF parallelisation of the call to IOIPSL routine ioconf_setatt
169	!!
170	!! DESCRIPTION: NONE
171	!!
172	!! \n
173	!_ ==============================================================================================================================
174	SUBROUTINE ioconf_setatt_p (attname,attvalue)
175	!---------------------------------------------------------------------
176	IMPLICIT NONE
177	!-
178	CHARACTER(LEN=*), INTENT(in) :: attname,attvalue
179	!---------------------------------------------------------------------
180
181	IF (is_root_prc) THEN
182	CALL ioconf_setatt(attname,attvalue)
183	ENDIF
184
185	END SUBROUTINE ioconf_setatt_p
186
187	!! =============================================================================================================================
188	!! SUBROUTINE: ipslnlf_p
189	!!
190	!>\BRIEF parallelisation of the call to IOIPSL routine ipslnlf
191	!!
192	!! DESCRIPTION: The "ipslnlf" routine allows to know and modify the current logical number for the messages.
193	!!
194	!! \n
195	!_ ==============================================================================================================================
196	SUBROUTINE ipslnlf_p (new_number,old_number)
197	!!--------------------------------------------------------------------
198	!! The "ipslnlf" routine allows to know and modify
199	!! the current logical number for the messages.
200	!!
201	!! SUBROUTINE ipslnlf (new_number,old_number)
202	!!
203	!! Optional INPUT argument
204	!!
205	!! (I) new_number : new logical number of the file
206	!!
207	!! Optional OUTPUT argument
208	!!
209	!! (I) old_number : current logical number of the file
210	!!--------------------------------------------------------------------
211	IMPLICIT NONE
212	!-
213	INTEGER,OPTIONAL,INTENT(IN) :: new_number
214	INTEGER,OPTIONAL,INTENT(OUT) :: old_number
215	!---------------------------------------------------------------------
216	IF (PRESENT(old_number)) THEN
217	#ifndef CPP_OMP
218	CALL ipslnlf(old_number=orch_ipslout)
219	#endif
220	old_number = orch_ipslout
221	ENDIF
222	IF (PRESENT(new_number)) THEN
223	orch_ipslout = new_number
224	#ifndef CPP_OMP
225	CALL ipslnlf(new_number=orch_ipslout)
226	#endif
227	ENDIF
228
229	END SUBROUTINE ipslnlf_p
230
231	!! =============================================================================================================================
232	!! SUBROUTINE: ipslerr_p
233	!!
234	!>\BRIEF allows to handle the messages to the user.
235	!!
236	!! DESCRIPTION: NONE
237	!!
238	!! \n
239	!_ ==============================================================================================================================
240	!===
241	SUBROUTINE ipslerr_p (plev,pcname,pstr1,pstr2,pstr3)
242	!---------------------------------------------------------------------
243	!! The "ipslerr_p" routine
244	!! allows to handle the messages to the user.
245	!!
246	!! parallel version of IOIPSL ipslerr
247	!!
248	!! INPUT
249	!!
250	!! plev : Category of message to be reported to the user
251	!! 1 = Note to the user
252	!! 2 = Warning to the user
253	!! 3 = Fatal error
254	!! pcname : Name of subroutine which has called ipslerr
255	!! pstr1
256	!! pstr2 : Strings containing the explanations to the user
257	!! pstr3
258	!---------------------------------------------------------------------
259	IMPLICIT NONE
260	!-
261	INTEGER :: plev
262	CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
263	!-
264	CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
265	& (/ "NOTE TO THE USER FROM ROUTINE ", &
266	& "WARNING FROM ROUTINE ", &
267	& "FATAL ERROR FROM ROUTINE " /)
268	!---------------------------------------------------------------------
269	IF ( (plev >= 1).AND.(plev <= 3) ) THEN
270	orch_ilv_cur = plev
271	orch_ilv_max = MAX(orch_ilv_max,plev)
272	WRITE(orch_ipslout,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
273	WRITE(orch_ipslout,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3)
274	ENDIF
275	IF (plev == 3) THEN
276	WRITE(orch_ipslout,'("Fatal error from ORCHIDEE. STOP in ipslerr_p with code")')
277	#ifdef CPP_PARA
278	CALL MPI_ABORT(plev)
279	#endif
280	STOP 1
281	ENDIF
282	!---------------------
283	END SUBROUTINE ipslerr_p
284
285
286	!! =============================================================================================================================
287	!! SUBROUTINE: getin_p_c
288	!!
289	!>\BRIEF get a character variable in text input file
290	!!
291	!! DESCRIPTION: Need to be call by all process
292	!!
293	!! \n
294	!_ ==============================================================================================================================
295	SUBROUTINE getin_p_c(VarIn,VarOut)
296	IMPLICIT NONE
297	CHARACTER(LEN=*),INTENT(IN) :: VarIn
298	CHARACTER(LEN=*),INTENT(INOUT) :: VarOut
299
300	IF (is_root_prc) CALL getin(VarIn,VarOut)
301	CALL bcast(VarOut)
302	END SUBROUTINE getin_p_c
303
304	!! =============================================================================================================================
305	!! SUBROUTINE: getin_p_c1
306	!!
307	!>\BRIEF get a character 1D array in text input file
308	!!
309	!! DESCRIPTION: Need to be call by all process
310	!!
311	!! \n
312	!_ ==============================================================================================================================
313	SUBROUTINE getin_p_c1(VarIn,VarOut)
314	IMPLICIT NONE
315	CHARACTER(LEN=*),INTENT(IN) :: VarIn
316	CHARACTER(LEN=*),INTENT(INOUT) :: VarOut(:)
317
318	IF (is_root_prc) CALL getin(VarIn,VarOut)
319	CALL bcast(VarOut)
320	END SUBROUTINE getin_p_c1
321
322	!! =============================================================================================================================
323	!! SUBROUTINE: getin_p_i
324	!!
325	!>\BRIEF get an integer variable in text input file
326	!!
327	!! DESCRIPTION: Need to be call by all process
328	!!
329	!! \n
330	!_ ==============================================================================================================================
331	SUBROUTINE getin_p_i(VarIn,VarOut)
332	IMPLICIT NONE
333	CHARACTER(LEN=*),INTENT(IN) :: VarIn
334	INTEGER,INTENT(INOUT) :: VarOut
335
336	IF (is_root_prc) CALL getin(VarIn,VarOut)
337	CALL bcast(VarOut)
338	END SUBROUTINE getin_p_i
339
340	!! =============================================================================================================================
341	!! SUBROUTINE: getin_p_i1
342	!!
343	!>\BRIEF get an integer 1D array in text input file
344	!!
345	!! DESCRIPTION: Need to be call by all process
346	!!
347	!! \n
348	!_ ==============================================================================================================================
349	SUBROUTINE getin_p_i1(VarIn,VarOut)
350	IMPLICIT NONE
351	CHARACTER(LEN=*),INTENT(IN) :: VarIn
352	INTEGER,INTENT(INOUT) :: VarOut(:)
353
354	IF (is_root_prc) CALL getin(VarIn,VarOut)
355	CALL bcast(VarOut)
356	END SUBROUTINE getin_p_i1
357
358	!! =============================================================================================================================
359	!! SUBROUTINE: getin_p_i2
360	!!
361	!>\BRIEF get an integer 2D array in text input file
362	!!
363	!! DESCRIPTION: Need to be call by all process
364	!!
365	!! \n
366	!_ ==============================================================================================================================
367	SUBROUTINE getin_p_i2(VarIn,VarOut)
368	IMPLICIT NONE
369	CHARACTER(LEN=*),INTENT(IN) :: VarIn
370	INTEGER,INTENT(INOUT) :: VarOut(:,:)
371
372	IF (is_root_prc) CALL getin(VarIn,VarOut)
373	CALL bcast(VarOut)
374	END SUBROUTINE getin_p_i2
375
376	!! =============================================================================================================================
377	!! SUBROUTINE: getin_p_r
378	!!
379	!>\BRIEF get a float variable in text input file
380	!!
381	!! DESCRIPTION: Need to be call by all process
382	!!
383	!! \n
384	!_ ==============================================================================================================================
385	SUBROUTINE getin_p_r(VarIn,VarOut)
386	IMPLICIT NONE
387	CHARACTER(LEN=*),INTENT(IN) :: VarIn
388	REAL,INTENT(INOUT) :: VarOut
389
390	IF (is_root_prc) CALL getin(VarIn,VarOut)
391	CALL bcast(VarOut)
392	END SUBROUTINE getin_p_r
393
394	!! =============================================================================================================================
395	!! SUBROUTINE: getin_p_r1
396	!!
397	!>\BRIEF get a float 1D array in text input file
398	!!
399	!! DESCRIPTION: Need to be call by all process
400	!!
401	!! \n
402	!_ ==============================================================================================================================
403	SUBROUTINE getin_p_r1(VarIn,VarOut)
404	IMPLICIT NONE
405	CHARACTER(LEN=*),INTENT(IN) :: VarIn
406	REAL,INTENT(INOUT) :: VarOut(:)
407
408	IF (is_root_prc) CALL getin(VarIn,VarOut)
409	CALL bcast(VarOut)
410	END SUBROUTINE getin_p_r1
411
412	!! =============================================================================================================================
413	!! SUBROUTINE: getin_p_r2
414	!!
415	!>\BRIEF get a float 2D array in text input file
416	!!
417	!! DESCRIPTION: Need to be call by all process
418	!!
419	!! \n
420	!_ ==============================================================================================================================
421	SUBROUTINE getin_p_r2(VarIn,VarOut)
422	IMPLICIT NONE
423	CHARACTER(LEN=*),INTENT(IN) :: VarIn
424	REAL,INTENT(INOUT) :: VarOut(:,:)
425
426	IF (is_root_prc) CALL getin(VarIn,VarOut)
427	CALL bcast(VarOut)
428	END SUBROUTINE getin_p_r2
429
430
431	!! =============================================================================================================================
432	!! SUBROUTINE: getin_p_l
433	!!
434	!>\BRIEF get a logical variable in text input file
435	!!
436	!! DESCRIPTION: Need to be call by all process
437	!!
438	!! \n
439	!_ ==============================================================================================================================
440	SUBROUTINE getin_p_l(VarIn,VarOut)
441	IMPLICIT NONE
442	CHARACTER(LEN=*),INTENT(IN) :: VarIn
443	LOGICAL,INTENT(INOUT) :: VarOut
444
445	IF (is_root_prc) CALL getin(VarIn,VarOut)
446	CALL bcast(VarOut)
447	END SUBROUTINE getin_p_l
448
449	!! =============================================================================================================================
450	!! SUBROUTINE: getin_p_l1
451	!!
452	!>\BRIEF get a logical 1D array in text input file
453	!!
454	!! DESCRIPTION: Need to be call by all process
455	!!
456	!! \n
457	!_ ==============================================================================================================================
458	SUBROUTINE getin_p_l1(VarIn,VarOut)
459	IMPLICIT NONE
460	CHARACTER(LEN=*),INTENT(IN) :: VarIn
461	LOGICAL,INTENT(INOUT) :: VarOut(:)
462
463	IF (is_root_prc) CALL getin(VarIn,VarOut)
464	CALL bcast(VarOut)
465	END SUBROUTINE getin_p_l1
466
467	!! =============================================================================================================================
468	!! SUBROUTINE: getin_p_l2
469	!!
470	!>\BRIEF get a logical 2D array in text input file
471	!!
472	!! DESCRIPTION: Need to be call by all process
473	!!
474	!! \n
475	!_ ==============================================================================================================================
476	SUBROUTINE getin_p_l2(VarIn,VarOut)
477	IMPLICIT NONE
478	CHARACTER(LEN=*),INTENT(IN) :: VarIn
479	LOGICAL,INTENT(INOUT) :: VarOut(:,:)
480
481	IF (is_root_prc) CALL getin(VarIn,VarOut)
482	CALL bcast(VarOut)
483	END SUBROUTINE getin_p_l2
484	!-
485
486	!! =============================================================================================================================
487	!! SUBROUTINE: restget_p_opp_r1d
488	!!
489	!>\BRIEF Transform the data (real 1D) from the restart file onto the model grid with the operation MY_OPERATOR
490	!!
491	!! DESCRIPTION: do not use this function with non grid variable
492	!!
493	!! \n
494	!_ ==============================================================================================================================
495	SUBROUTINE restget_p_opp_r1d &
496	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
497	var, MY_OPERATOR, nbindex, ijndex)
498	! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
499	IMPLICIT NONE
500	!-
501	INTEGER :: fid
502	CHARACTER(LEN=*) :: vname_q
503	INTEGER :: iim, jjm, llm, itau
504	LOGICAL def_beha
505	REAL :: var(:)
506	CHARACTER(LEN=*) :: MY_OPERATOR
507	INTEGER :: nbindex, ijndex(nbindex)
508	!-----------------------------
509	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
510
511	IF (is_root_prc) THEN
512	ALLOCATE( temp_g(iimjjmllm) )
513	ELSE
514	ALLOCATE( temp_g(1) )
515	ENDIF
516
517	IF (is_root_prc) THEN
518	CALL restget &
519	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
520	temp_g, MY_OPERATOR, nbindex, ijndex)
521	ENDIF
522	CALL scatter(temp_g,var)
523	DEALLOCATE(temp_g)
524	END SUBROUTINE restget_p_opp_r1d
525
526	!! =============================================================================================================================
527	!! SUBROUTINE: restget_p_opp_r2d
528	!!
529	!>\BRIEF Transform the data (real 2D) from the restart file onto the model grid with the operation MY_OPERATOR
530	!!
531	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
532	!!
533	!! \n
534	!_ ==============================================================================================================================
535	SUBROUTINE restget_p_opp_r2d &
536	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
537	var, MY_OPERATOR, nbindex, ijndex)
538	IMPLICIT NONE
539	!-
540	INTEGER :: fid
541	CHARACTER(LEN=*) :: vname_q
542	INTEGER :: iim, jjm, llm, itau
543	LOGICAL def_beha
544	REAL :: var(:,:)
545	CHARACTER(LEN=*) :: MY_OPERATOR
546	INTEGER :: nbindex, ijndex(nbindex)
547	!-----------------------------
548	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
549
550	IF (is_root_prc) THEN
551	ALLOCATE( temp_g(iim,jjm) )
552	ELSE
553	ALLOCATE( temp_g(1,1) )
554	ENDIF
555
556	IF (is_root_prc) THEN
557	CALL restget &
558	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
559	temp_g, MY_OPERATOR, nbindex, ijndex)
560	ENDIF
561	CALL scatter(temp_g,var)
562	DEALLOCATE(temp_g)
563	END SUBROUTINE restget_p_opp_r2d
564
565	!! =============================================================================================================================
566	!! SUBROUTINE: restget_p_r1d
567	!!
568	!>\BRIEF Transform the data (real 1D) from the restart file onto the model grid
569	!!
570	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
571	!! \n
572	!_ ==============================================================================================================================
573	SUBROUTINE restget_p_r1d &
574	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
575	! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
576	IMPLICIT NONE
577	!-
578	INTEGER :: fid
579	CHARACTER(LEN=*) :: vname_q
580	INTEGER :: iim, jjm, llm, itau
581	LOGICAL :: def_beha
582	REAL :: var(:)
583	!-------------------------
584	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
585
586	IF (is_root_prc) THEN
587	ALLOCATE( temp_g(iimjjmllm) )
588	ELSE
589	ALLOCATE( temp_g(1) )
590	ENDIF
591
592	IF (is_root_prc) THEN
593	CALL restget &
594	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
595	ENDIF
596	CALL scatter(temp_g,var)
597	DEALLOCATE(temp_g)
598	END SUBROUTINE restget_p_r1d
599
600	!! =============================================================================================================================
601	!! SUBROUTINE: restget_p_r2d
602	!!
603	!>\BRIEF Transform the data (real 2D) from the restart file onto the model grid
604	!!
605	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
606	!! \n
607	!_ ==============================================================================================================================
608	SUBROUTINE restget_p_r2d &
609	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
610	IMPLICIT NONE
611	!-
612	INTEGER :: fid
613	CHARACTER(LEN=*) :: vname_q
614	INTEGER :: iim, jjm, llm, itau
615	LOGICAL :: def_beha
616	REAL :: var(:,:)
617	!-------------------------
618	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
619
620	IF (is_root_prc) THEN
621	ALLOCATE( temp_g(iim,jjm) )
622	ELSE
623	ALLOCATE( temp_g(1,1) )
624	ENDIF
625	IF (is_root_prc) THEN
626	CALL restget &
627	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
628	ENDIF
629	CALL scatter(temp_g,var)
630	DEALLOCATE(temp_g)
631	END SUBROUTINE restget_p_r2d
632
633	!! =============================================================================================================================
634	!! SUBROUTINE: restget_p_r3d
635	!!
636	!>\BRIEF Transform the data (real 3D) from the restart file onto the model grid
637	!!
638	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
639	!! \n
640	!_ ==============================================================================================================================
641	SUBROUTINE restget_p_r3d &
642	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
643	IMPLICIT NONE
644	!-
645	INTEGER :: fid
646	CHARACTER(LEN=*) :: vname_q
647	INTEGER :: iim, jjm, llm, itau
648	LOGICAL def_beha
649	REAL :: var(:,:,:)
650	!-------------------------
651	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
652
653	IF (is_root_prc) THEN
654	ALLOCATE( temp_g(iim,jjm,llm) )
655	ELSE
656	ALLOCATE( temp_g(1,1,1) )
657	ENDIF
658
659	IF (is_root_prc) THEN
660	CALL restget &
661	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
662	ENDIF
663	CALL scatter(temp_g,var)
664	DEALLOCATE(temp_g)
665	END SUBROUTINE restget_p_r3d
666
667	!! =============================================================================================================================
668	!! SUBROUTINE: restput_p_opp_r1d
669	!!
670	!>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file with the operation MY_OPERATOR
671	!!
672	!! DESCRIPTION: Need to be call by all process
673	!! \n
674	!_ ==============================================================================================================================
675	SUBROUTINE restput_p_opp_r1d &
676	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
677	IMPLICIT NONE
678	!-
679	INTEGER :: fid
680	CHARACTER(LEN=*) :: vname_q
681	INTEGER :: iim, jjm, llm, itau
682	REAL :: var(:)
683	CHARACTER(LEN=*) :: MY_OPERATOR
684	INTEGER :: nbindex, ijndex(nbindex)
685	!-----------------------------
686	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
687
688	IF (is_root_prc) THEN
689	ALLOCATE( temp_g(iimjjmllm) )
690	ELSE
691	ALLOCATE ( temp_g(1) )
692	ENDIF
693
694	CALL gather(var,temp_g)
695	IF (is_root_prc) THEN
696	CALL restput &
697	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
698	ENDIF
699
700	DEALLOCATE( temp_g )
701
702	END SUBROUTINE restput_p_opp_r1d
703
704	!! =============================================================================================================================
705	!! SUBROUTINE: restput_p_opp_r2d
706	!!
707	!>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file with the operation MY_OPERATOR
708	!!
709	!! DESCRIPTION: Need to be call by all process
710	!! \n
711	!_ ==============================================================================================================================
712	SUBROUTINE restput_p_opp_r2d &
713	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
714	IMPLICIT NONE
715	!-
716	INTEGER :: fid
717	CHARACTER(LEN=*) :: vname_q
718	INTEGER :: iim, jjm, llm, itau
719	REAL :: var(:,:)
720	CHARACTER(LEN=*) :: MY_OPERATOR
721	INTEGER :: nbindex, ijndex(nbindex)
722	!-----------------------------
723	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
724
725	IF (is_root_prc) THEN
726	ALLOCATE( temp_g(iim,jjm) )
727	ELSE
728	ALLOCATE( temp_g(1,1) )
729	ENDIF
730
731	CALL gather(var,temp_g)
732	IF (is_root_prc) THEN
733	CALL restput &
734	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
735	ENDIF
736	DEALLOCATE( temp_g )
737
738	END SUBROUTINE restput_p_opp_r2d
739
740	!! =============================================================================================================================
741	!! SUBROUTINE: restput_p_r1d
742	!!
743	!>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file
744	!!
745	!! DESCRIPTION: Need to be call by all process
746	!!
747	!! \n
748	!_ ==============================================================================================================================
749	SUBROUTINE restput_p_r1d (fid,vname_q,iim,jjm,llm,itau,var)
750	IMPLICIT NONE
751	!-
752	INTEGER :: fid
753	CHARACTER(LEN=*) :: vname_q
754	INTEGER :: iim, jjm, llm, itau
755	REAL :: var(:)
756	!-----------------------------
757	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
758
759	IF (is_root_prc) THEN
760	ALLOCATE( temp_g(iimjjmllm) )
761	ELSE
762	ALLOCATE( temp_g(1) )
763	ENDIF
764
765	CALL gather(var,temp_g)
766	IF (is_root_prc) THEN
767	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
768	ENDIF
769	DEALLOCATE( temp_g )
770
771	END SUBROUTINE restput_p_r1d
772
773	!! =============================================================================================================================
774	!! SUBROUTINE: restput_p_r2d
775	!!
776	!>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file
777	!!
778	!! DESCRIPTION: Need to be call by all process
779	!!
780	!! \n
781	!_ ==============================================================================================================================
782	SUBROUTINE restput_p_r2d (fid,vname_q,iim,jjm,llm,itau,var)
783	IMPLICIT NONE
784	!-
785	INTEGER :: fid
786	CHARACTER(LEN=*) :: vname_q
787	INTEGER :: iim, jjm, llm, itau
788	REAL :: var(:,:)
789	!-------------------------
790	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
791
792	IF (is_root_prc) THEN
793	ALLOCATE( temp_g(iim,jjm) )
794	ELSE
795	ALLOCATE( temp_g(1,1) )
796	ENDIF
797
798	CALL gather(var,temp_g)
799	IF (is_root_prc) THEN
800	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
801	ENDIF
802	DEALLOCATE( temp_g )
803
804	END SUBROUTINE restput_p_r2d
805
806	!! =============================================================================================================================
807	!! SUBROUTINE: restput_p_r3d
808	!!
809	!>\BRIEF allows to re-index data (real 3D) onto the original grid of the restart file
810	!!
811	!! DESCRIPTION: Need to be call by all process
812	!!
813	!! \n
814	!_ ==============================================================================================================================
815	SUBROUTINE restput_p_r3d (fid,vname_q,iim,jjm,llm,itau,var)
816	IMPLICIT NONE
817	!-
818	INTEGER :: fid
819	CHARACTER(LEN=*) :: vname_q
820	INTEGER :: iim, jjm, llm, itau
821	REAL :: var(:,:,:)
822	!-------------------------
823	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
824
825	IF (is_root_prc) THEN
826	ALLOCATE( temp_g(iim,jjm,llm) )
827	ELSE
828	ALLOCATE( temp_g(iim,jjm,llm) )
829	ENDIF
830
831	CALL gather(var,temp_g)
832	IF (is_root_prc) THEN
833	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
834	ENDIF
835	DEALLOCATE( temp_g )
836
837	END SUBROUTINE restput_p_r3d
838
839	!! =============================================================================================================================
840	!! SUBROUTINE: histwrite_r1d_p
841	!!
842	!>\BRIEF give the data (real 1D) to the IOIPSL system (if we don't use XIOS).
843	!!
844	!! DESCRIPTION: Need to be call by all process
845	!!
846	!! \n
847	!_ ==============================================================================================================================
848	SUBROUTINE histwrite_r1d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
849	IMPLICIT NONE
850	!-
851	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
852	REAL,DIMENSION(:),INTENT(IN) :: pdata
853	CHARACTER(LEN=*),INTENT(IN) :: pvarname
854
855	REAL,DIMENSION(nbp_mpi) :: pdata_mpi
856
857	IF (pfileid > 0) THEN
858	! Continue only if the file is initilalized
859	CALL gather_omp(pdata,pdata_mpi)
860	IF (is_omp_root) THEN
861	CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpi,kindex_mpi)
862	ENDIF
863	END IF
864
865	END SUBROUTINE histwrite_r1d_p
866
867	!! =============================================================================================================================
868	!! SUBROUTINE: histwrite_r2d_p
869	!!
870	!>\BRIEF give the data (real 2D) to the IOIPSL system (if we don't use XIOS).
871	!!
872	!! DESCRIPTION: Need to be call by all process
873	!!
874	!! \n
875	!_ ==============================================================================================================================
876	SUBROUTINE histwrite_r2d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
877	IMPLICIT NONE
878	!-
879	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
880	REAL,DIMENSION(:,:),INTENT(IN) :: pdata
881	CHARACTER(LEN=*),INTENT(IN) :: pvarname
882
883	IF (pfileid > 0) THEN
884	! Continue only if the file is initilalized
885	CALL body(size(pdata,2),nindex)
886	END IF
887
888	CONTAINS
889
890	SUBROUTINE body(dim,nindex)
891	INTEGER :: dim
892	INTEGER :: nindex(nbp_omp,dim)
893
894	INTEGER :: nindex_mpi(nbp_mpi,dim)
895	REAL :: pdata_mpi(nbp_mpi,dim)
896
897	CALL gather_omp(pdata,pdata_mpi)
898	CALL gather_omp(nindex,nindex_mpi)
899
900	IF (is_omp_root) THEN
901	CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpidim,reshape(nindex_mpi,(/nbp_mpidim/)))
902	ENDIF
903	END SUBROUTINE body
904
905	END SUBROUTINE histwrite_r2d_p
906
907	!! =============================================================================================================================
908	!! SUBROUTINE: histwrite_r3d_p
909	!!
910	!>\BRIEF give the data (real 3D) to the IOIPSL system (if we don't use XIOS).
911	!!
912	!! DESCRIPTION: Need to be call by all process
913	!!
914	!! \n
915	!_ ==============================================================================================================================
916	SUBROUTINE histwrite_r3d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
917	IMPLICIT NONE
918	!-
919	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
920	REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata
921	CHARACTER(LEN=*),INTENT(IN) :: pvarname
922
923	STOP 2
924
925	END SUBROUTINE histwrite_r3d_p
926
927
928	END MODULE ioipsl_para

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

Download in other formats: