Context Navigation

source: tags/ORCHIDEE_2_0/ORCHIDEE/src_parallel/ioipsl_para.f90

Last change on this file was 4683, checked in by josefine.ghattas, 7 years ago
Added arguments for call mpi_abort, see ticket #391
Property svn:keywords set to `HeadURL Date Author Revision`
File size: 32.7 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	!-
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	#ifdef CPP_PARA
262	INCLUDE 'mpif.h'
263	#endif
264
265	INTEGER :: plev
266	CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
267
268	CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
269	& (/ "NOTE TO THE USER FROM ROUTINE ", &
270	& "WARNING FROM ROUTINE ", &
271	& "FATAL ERROR FROM ROUTINE " /)
272	INTEGER :: ierr
273	!---------------------------------------------------------------------
274	IF ( (plev >= 1).AND.(plev <= 3) ) THEN
275	orch_ilv_cur = plev
276	orch_ilv_max = MAX(orch_ilv_max,plev)
277	WRITE(orch_ipslout,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
278	WRITE(orch_ipslout,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3)
279	ENDIF
280	IF (plev == 3) THEN
281	WRITE(orch_ipslout,'("Fatal error from ORCHIDEE. STOP in ipslerr_p with code")')
282	! Force to pring text output using FLUSH only if cpp flag CPP_FLUSH is set in arch-XXX.fcm
283	#ifdef CPP_FLUSH
284	CALL FLUSH(orch_ipslout)
285	#endif
286
287	#ifdef CPP_PARA
288	CALL MPI_ABORT(MPI_COMM_WORLD, 1, ierr)
289	#endif
290	STOP 1
291	ENDIF
292	!---------------------
293	END SUBROUTINE ipslerr_p
294
295
296	!! =============================================================================================================================
297	!! SUBROUTINE: getin_p_c
298	!!
299	!>\BRIEF get a character variable in text input file
300	!!
301	!! DESCRIPTION: Need to be call by all process
302	!!
303	!! \n
304	!_ ==============================================================================================================================
305	SUBROUTINE getin_p_c(VarIn,VarOut)
306	IMPLICIT NONE
307	CHARACTER(LEN=*),INTENT(IN) :: VarIn
308	CHARACTER(LEN=*),INTENT(INOUT) :: VarOut
309
310	IF (is_root_prc) CALL getin(VarIn,VarOut)
311	CALL bcast(VarOut)
312	END SUBROUTINE getin_p_c
313
314	!! =============================================================================================================================
315	!! SUBROUTINE: getin_p_c1
316	!!
317	!>\BRIEF get a character 1D array in text input file
318	!!
319	!! DESCRIPTION: Need to be call by all process
320	!!
321	!! \n
322	!_ ==============================================================================================================================
323	SUBROUTINE getin_p_c1(VarIn,VarOut)
324	IMPLICIT NONE
325	CHARACTER(LEN=*),INTENT(IN) :: VarIn
326	CHARACTER(LEN=*),INTENT(INOUT) :: VarOut(:)
327
328	IF (is_root_prc) CALL getin(VarIn,VarOut)
329	CALL bcast(VarOut)
330	END SUBROUTINE getin_p_c1
331
332	!! =============================================================================================================================
333	!! SUBROUTINE: getin_p_i
334	!!
335	!>\BRIEF get an integer variable in text input file
336	!!
337	!! DESCRIPTION: Need to be call by all process
338	!!
339	!! \n
340	!_ ==============================================================================================================================
341	SUBROUTINE getin_p_i(VarIn,VarOut)
342	IMPLICIT NONE
343	CHARACTER(LEN=*),INTENT(IN) :: VarIn
344	INTEGER,INTENT(INOUT) :: VarOut
345
346	IF (is_root_prc) CALL getin(VarIn,VarOut)
347	CALL bcast(VarOut)
348	END SUBROUTINE getin_p_i
349
350	!! =============================================================================================================================
351	!! SUBROUTINE: getin_p_i1
352	!!
353	!>\BRIEF get an integer 1D array in text input file
354	!!
355	!! DESCRIPTION: Need to be call by all process
356	!!
357	!! \n
358	!_ ==============================================================================================================================
359	SUBROUTINE getin_p_i1(VarIn,VarOut)
360	IMPLICIT NONE
361	CHARACTER(LEN=*),INTENT(IN) :: VarIn
362	INTEGER,INTENT(INOUT) :: VarOut(:)
363
364	IF (is_root_prc) CALL getin(VarIn,VarOut)
365	CALL bcast(VarOut)
366	END SUBROUTINE getin_p_i1
367
368	!! =============================================================================================================================
369	!! SUBROUTINE: getin_p_i2
370	!!
371	!>\BRIEF get an integer 2D array in text input file
372	!!
373	!! DESCRIPTION: Need to be call by all process
374	!!
375	!! \n
376	!_ ==============================================================================================================================
377	SUBROUTINE getin_p_i2(VarIn,VarOut)
378	IMPLICIT NONE
379	CHARACTER(LEN=*),INTENT(IN) :: VarIn
380	INTEGER,INTENT(INOUT) :: VarOut(:,:)
381
382	IF (is_root_prc) CALL getin(VarIn,VarOut)
383	CALL bcast(VarOut)
384	END SUBROUTINE getin_p_i2
385
386	!! =============================================================================================================================
387	!! SUBROUTINE: getin_p_r
388	!!
389	!>\BRIEF get a float variable in text input file
390	!!
391	!! DESCRIPTION: Need to be call by all process
392	!!
393	!! \n
394	!_ ==============================================================================================================================
395	SUBROUTINE getin_p_r(VarIn,VarOut)
396	IMPLICIT NONE
397	CHARACTER(LEN=*),INTENT(IN) :: VarIn
398	REAL,INTENT(INOUT) :: VarOut
399
400	IF (is_root_prc) CALL getin(VarIn,VarOut)
401	CALL bcast(VarOut)
402	END SUBROUTINE getin_p_r
403
404	!! =============================================================================================================================
405	!! SUBROUTINE: getin_p_r1
406	!!
407	!>\BRIEF get a float 1D array in text input file
408	!!
409	!! DESCRIPTION: Need to be call by all process
410	!!
411	!! \n
412	!_ ==============================================================================================================================
413	SUBROUTINE getin_p_r1(VarIn,VarOut)
414	IMPLICIT NONE
415	CHARACTER(LEN=*),INTENT(IN) :: VarIn
416	REAL,INTENT(INOUT) :: VarOut(:)
417
418	IF (is_root_prc) CALL getin(VarIn,VarOut)
419	CALL bcast(VarOut)
420	END SUBROUTINE getin_p_r1
421
422	!! =============================================================================================================================
423	!! SUBROUTINE: getin_p_r2
424	!!
425	!>\BRIEF get a float 2D array in text input file
426	!!
427	!! DESCRIPTION: Need to be call by all process
428	!!
429	!! \n
430	!_ ==============================================================================================================================
431	SUBROUTINE getin_p_r2(VarIn,VarOut)
432	IMPLICIT NONE
433	CHARACTER(LEN=*),INTENT(IN) :: VarIn
434	REAL,INTENT(INOUT) :: VarOut(:,:)
435
436	IF (is_root_prc) CALL getin(VarIn,VarOut)
437	CALL bcast(VarOut)
438	END SUBROUTINE getin_p_r2
439
440
441	!! =============================================================================================================================
442	!! SUBROUTINE: getin_p_l
443	!!
444	!>\BRIEF get a logical variable in text input file
445	!!
446	!! DESCRIPTION: Need to be call by all process
447	!!
448	!! \n
449	!_ ==============================================================================================================================
450	SUBROUTINE getin_p_l(VarIn,VarOut)
451	IMPLICIT NONE
452	CHARACTER(LEN=*),INTENT(IN) :: VarIn
453	LOGICAL,INTENT(INOUT) :: VarOut
454
455	IF (is_root_prc) CALL getin(VarIn,VarOut)
456	CALL bcast(VarOut)
457	END SUBROUTINE getin_p_l
458
459	!! =============================================================================================================================
460	!! SUBROUTINE: getin_p_l1
461	!!
462	!>\BRIEF get a logical 1D array in text input file
463	!!
464	!! DESCRIPTION: Need to be call by all process
465	!!
466	!! \n
467	!_ ==============================================================================================================================
468	SUBROUTINE getin_p_l1(VarIn,VarOut)
469	IMPLICIT NONE
470	CHARACTER(LEN=*),INTENT(IN) :: VarIn
471	LOGICAL,INTENT(INOUT) :: VarOut(:)
472
473	IF (is_root_prc) CALL getin(VarIn,VarOut)
474	CALL bcast(VarOut)
475	END SUBROUTINE getin_p_l1
476
477	!! =============================================================================================================================
478	!! SUBROUTINE: getin_p_l2
479	!!
480	!>\BRIEF get a logical 2D array in text input file
481	!!
482	!! DESCRIPTION: Need to be call by all process
483	!!
484	!! \n
485	!_ ==============================================================================================================================
486	SUBROUTINE getin_p_l2(VarIn,VarOut)
487	IMPLICIT NONE
488	CHARACTER(LEN=*),INTENT(IN) :: VarIn
489	LOGICAL,INTENT(INOUT) :: VarOut(:,:)
490
491	IF (is_root_prc) CALL getin(VarIn,VarOut)
492	CALL bcast(VarOut)
493	END SUBROUTINE getin_p_l2
494	!-
495
496	!! =============================================================================================================================
497	!! SUBROUTINE: restget_p_opp_r1d
498	!!
499	!>\BRIEF Transform the data (real 1D) from the restart file onto the model grid with the operation MY_OPERATOR
500	!!
501	!! DESCRIPTION: do not use this function with non grid variable
502	!!
503	!! \n
504	!_ ==============================================================================================================================
505	SUBROUTINE restget_p_opp_r1d &
506	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
507	var, MY_OPERATOR, nbindex, ijndex)
508	! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
509	IMPLICIT NONE
510	!-
511	INTEGER :: fid
512	CHARACTER(LEN=*) :: vname_q
513	INTEGER :: iim, jjm, llm, itau
514	LOGICAL def_beha
515	REAL :: var(:)
516	CHARACTER(LEN=*) :: MY_OPERATOR
517	INTEGER :: nbindex, ijndex(nbindex)
518	!-----------------------------
519	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
520
521	IF (is_root_prc) THEN
522	ALLOCATE( temp_g(iimjjmllm) )
523	ELSE
524	ALLOCATE( temp_g(1) )
525	ENDIF
526
527	IF (is_root_prc) THEN
528	CALL restget &
529	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
530	temp_g, MY_OPERATOR, nbindex, ijndex)
531	ENDIF
532	CALL scatter(temp_g,var)
533	DEALLOCATE(temp_g)
534	END SUBROUTINE restget_p_opp_r1d
535
536	!! =============================================================================================================================
537	!! SUBROUTINE: restget_p_opp_r2d
538	!!
539	!>\BRIEF Transform the data (real 2D) from the restart file onto the model grid with the operation MY_OPERATOR
540	!!
541	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
542	!!
543	!! \n
544	!_ ==============================================================================================================================
545	SUBROUTINE restget_p_opp_r2d &
546	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
547	var, MY_OPERATOR, nbindex, ijndex)
548	IMPLICIT NONE
549	!-
550	INTEGER :: fid
551	CHARACTER(LEN=*) :: vname_q
552	INTEGER :: iim, jjm, llm, itau
553	LOGICAL def_beha
554	REAL :: var(:,:)
555	CHARACTER(LEN=*) :: MY_OPERATOR
556	INTEGER :: nbindex, ijndex(nbindex)
557	!-----------------------------
558	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
559
560	IF (is_root_prc) THEN
561	ALLOCATE( temp_g(iim,jjm) )
562	ELSE
563	ALLOCATE( temp_g(1,1) )
564	ENDIF
565
566	IF (is_root_prc) THEN
567	CALL restget &
568	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
569	temp_g, MY_OPERATOR, nbindex, ijndex)
570	ENDIF
571	CALL scatter(temp_g,var)
572	DEALLOCATE(temp_g)
573	END SUBROUTINE restget_p_opp_r2d
574
575	!! =============================================================================================================================
576	!! SUBROUTINE: restget_p_r1d
577	!!
578	!>\BRIEF Transform the data (real 1D) from the restart file onto the model grid
579	!!
580	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
581	!! \n
582	!_ ==============================================================================================================================
583	SUBROUTINE restget_p_r1d &
584	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
585	! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
586	IMPLICIT NONE
587	!-
588	INTEGER :: fid
589	CHARACTER(LEN=*) :: vname_q
590	INTEGER :: iim, jjm, llm, itau
591	LOGICAL :: def_beha
592	REAL :: var(:)
593	!-------------------------
594	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
595
596	IF (is_root_prc) THEN
597	ALLOCATE( temp_g(iimjjmllm) )
598	ELSE
599	ALLOCATE( temp_g(1) )
600	ENDIF
601
602	IF (is_root_prc) THEN
603	CALL restget &
604	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
605	ENDIF
606	CALL scatter(temp_g,var)
607	DEALLOCATE(temp_g)
608	END SUBROUTINE restget_p_r1d
609
610	!! =============================================================================================================================
611	!! SUBROUTINE: restget_p_r2d
612	!!
613	!>\BRIEF Transform the data (real 2D) from the restart file onto the model grid
614	!!
615	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
616	!! \n
617	!_ ==============================================================================================================================
618	SUBROUTINE restget_p_r2d &
619	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
620	IMPLICIT NONE
621	!-
622	INTEGER :: fid
623	CHARACTER(LEN=*) :: vname_q
624	INTEGER :: iim, jjm, llm, itau
625	LOGICAL :: def_beha
626	REAL :: var(:,:)
627	!-------------------------
628	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
629
630	IF (is_root_prc) THEN
631	ALLOCATE( temp_g(iim,jjm) )
632	ELSE
633	ALLOCATE( temp_g(1,1) )
634	ENDIF
635	IF (is_root_prc) THEN
636	CALL restget &
637	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
638	ENDIF
639	CALL scatter(temp_g,var)
640	DEALLOCATE(temp_g)
641	END SUBROUTINE restget_p_r2d
642
643	!! =============================================================================================================================
644	!! SUBROUTINE: restget_p_r3d
645	!!
646	!>\BRIEF Transform the data (real 3D) from the restart file onto the model grid
647	!!
648	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
649	!! \n
650	!_ ==============================================================================================================================
651	SUBROUTINE restget_p_r3d &
652	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
653	IMPLICIT NONE
654	!-
655	INTEGER :: fid
656	CHARACTER(LEN=*) :: vname_q
657	INTEGER :: iim, jjm, llm, itau
658	LOGICAL def_beha
659	REAL :: var(:,:,:)
660	!-------------------------
661	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
662
663	IF (is_root_prc) THEN
664	ALLOCATE( temp_g(iim,jjm,llm) )
665	ELSE
666	ALLOCATE( temp_g(1,1,1) )
667	ENDIF
668
669	IF (is_root_prc) THEN
670	CALL restget &
671	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
672	ENDIF
673	CALL scatter(temp_g,var)
674	DEALLOCATE(temp_g)
675	END SUBROUTINE restget_p_r3d
676
677	!! =============================================================================================================================
678	!! SUBROUTINE: restput_p_opp_r1d
679	!!
680	!>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file with the operation MY_OPERATOR
681	!!
682	!! DESCRIPTION: Need to be call by all process
683	!! \n
684	!_ ==============================================================================================================================
685	SUBROUTINE restput_p_opp_r1d &
686	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
687	IMPLICIT NONE
688	!-
689	INTEGER :: fid
690	CHARACTER(LEN=*) :: vname_q
691	INTEGER :: iim, jjm, llm, itau
692	REAL :: var(:)
693	CHARACTER(LEN=*) :: MY_OPERATOR
694	INTEGER :: nbindex, ijndex(nbindex)
695	!-----------------------------
696	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
697
698	IF (is_root_prc) THEN
699	ALLOCATE( temp_g(iimjjmllm) )
700	ELSE
701	ALLOCATE ( temp_g(1) )
702	ENDIF
703
704	CALL gather(var,temp_g)
705	IF (is_root_prc) THEN
706	CALL restput &
707	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
708	ENDIF
709
710	DEALLOCATE( temp_g )
711
712	END SUBROUTINE restput_p_opp_r1d
713
714	!! =============================================================================================================================
715	!! SUBROUTINE: restput_p_opp_r2d
716	!!
717	!>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file with the operation MY_OPERATOR
718	!!
719	!! DESCRIPTION: Need to be call by all process
720	!! \n
721	!_ ==============================================================================================================================
722	SUBROUTINE restput_p_opp_r2d &
723	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
724	IMPLICIT NONE
725	!-
726	INTEGER :: fid
727	CHARACTER(LEN=*) :: vname_q
728	INTEGER :: iim, jjm, llm, itau
729	REAL :: var(:,:)
730	CHARACTER(LEN=*) :: MY_OPERATOR
731	INTEGER :: nbindex, ijndex(nbindex)
732	!-----------------------------
733	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
734
735	IF (is_root_prc) THEN
736	ALLOCATE( temp_g(iim,jjm) )
737	ELSE
738	ALLOCATE( temp_g(1,1) )
739	ENDIF
740
741	CALL gather(var,temp_g)
742	IF (is_root_prc) THEN
743	CALL restput &
744	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
745	ENDIF
746	DEALLOCATE( temp_g )
747
748	END SUBROUTINE restput_p_opp_r2d
749
750	!! =============================================================================================================================
751	!! SUBROUTINE: restput_p_r1d
752	!!
753	!>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file
754	!!
755	!! DESCRIPTION: Need to be call by all process
756	!!
757	!! \n
758	!_ ==============================================================================================================================
759	SUBROUTINE restput_p_r1d (fid,vname_q,iim,jjm,llm,itau,var)
760	IMPLICIT NONE
761	!-
762	INTEGER :: fid
763	CHARACTER(LEN=*) :: vname_q
764	INTEGER :: iim, jjm, llm, itau
765	REAL :: var(:)
766	!-----------------------------
767	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
768
769	IF (is_root_prc) THEN
770	ALLOCATE( temp_g(iimjjmllm) )
771	ELSE
772	ALLOCATE( temp_g(1) )
773	ENDIF
774
775	CALL gather(var,temp_g)
776	IF (is_root_prc) THEN
777	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
778	ENDIF
779	DEALLOCATE( temp_g )
780
781	END SUBROUTINE restput_p_r1d
782
783	!! =============================================================================================================================
784	!! SUBROUTINE: restput_p_r2d
785	!!
786	!>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file
787	!!
788	!! DESCRIPTION: Need to be call by all process
789	!!
790	!! \n
791	!_ ==============================================================================================================================
792	SUBROUTINE restput_p_r2d (fid,vname_q,iim,jjm,llm,itau,var)
793	IMPLICIT NONE
794	!-
795	INTEGER :: fid
796	CHARACTER(LEN=*) :: vname_q
797	INTEGER :: iim, jjm, llm, itau
798	REAL :: var(:,:)
799	!-------------------------
800	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
801
802	IF (is_root_prc) THEN
803	ALLOCATE( temp_g(iim,jjm) )
804	ELSE
805	ALLOCATE( temp_g(1,1) )
806	ENDIF
807
808	CALL gather(var,temp_g)
809	IF (is_root_prc) THEN
810	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
811	ENDIF
812	DEALLOCATE( temp_g )
813
814	END SUBROUTINE restput_p_r2d
815
816	!! =============================================================================================================================
817	!! SUBROUTINE: restput_p_r3d
818	!!
819	!>\BRIEF allows to re-index data (real 3D) onto the original grid of the restart file
820	!!
821	!! DESCRIPTION: Need to be call by all process
822	!!
823	!! \n
824	!_ ==============================================================================================================================
825	SUBROUTINE restput_p_r3d (fid,vname_q,iim,jjm,llm,itau,var)
826	IMPLICIT NONE
827	!-
828	INTEGER :: fid
829	CHARACTER(LEN=*) :: vname_q
830	INTEGER :: iim, jjm, llm, itau
831	REAL :: var(:,:,:)
832	!-------------------------
833	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
834
835	IF (is_root_prc) THEN
836	ALLOCATE( temp_g(iim,jjm,llm) )
837	ELSE
838	ALLOCATE( temp_g(iim,jjm,llm) )
839	ENDIF
840
841	CALL gather(var,temp_g)
842	IF (is_root_prc) THEN
843	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
844	ENDIF
845	DEALLOCATE( temp_g )
846
847	END SUBROUTINE restput_p_r3d
848
849	!! =============================================================================================================================
850	!! SUBROUTINE: histwrite_r1d_p
851	!!
852	!>\BRIEF give the data (real 1D) to the IOIPSL system (if we don't use XIOS).
853	!!
854	!! DESCRIPTION: Need to be call by all process
855	!!
856	!! \n
857	!_ ==============================================================================================================================
858	SUBROUTINE histwrite_r1d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
859	IMPLICIT NONE
860	!-
861	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
862	REAL,DIMENSION(:),INTENT(IN) :: pdata
863	CHARACTER(LEN=*),INTENT(IN) :: pvarname
864
865	REAL,DIMENSION(nbp_mpi) :: pdata_mpi
866
867	IF (pfileid > 0) THEN
868	! Continue only if the file is initilalized
869	CALL gather_omp(pdata,pdata_mpi)
870	IF (is_omp_root) THEN
871	CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpi,kindex_mpi)
872	ENDIF
873	END IF
874
875	END SUBROUTINE histwrite_r1d_p
876
877	!! =============================================================================================================================
878	!! SUBROUTINE: histwrite_r2d_p
879	!!
880	!>\BRIEF give the data (real 2D) to the IOIPSL system (if we don't use XIOS).
881	!!
882	!! DESCRIPTION: Need to be call by all process
883	!!
884	!! \n
885	!_ ==============================================================================================================================
886	SUBROUTINE histwrite_r2d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
887	IMPLICIT NONE
888	!-
889	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
890	REAL,DIMENSION(:,:),INTENT(IN) :: pdata
891	CHARACTER(LEN=*),INTENT(IN) :: pvarname
892
893	IF (pfileid > 0) THEN
894	! Continue only if the file is initilalized
895	CALL body(size(pdata,2),nindex)
896	END IF
897
898	CONTAINS
899
900	SUBROUTINE body(dim,nindex)
901	INTEGER :: dim
902	INTEGER :: nindex(nbp_omp,dim)
903
904	INTEGER :: nindex_mpi(nbp_mpi,dim)
905	REAL :: pdata_mpi(nbp_mpi,dim)
906
907	CALL gather_omp(pdata,pdata_mpi)
908	CALL gather_omp(nindex,nindex_mpi)
909
910	IF (is_omp_root) THEN
911	CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpidim,reshape(nindex_mpi,(/nbp_mpidim/)))
912	ENDIF
913	END SUBROUTINE body
914
915	END SUBROUTINE histwrite_r2d_p
916
917	!! =============================================================================================================================
918	!! SUBROUTINE: histwrite_r3d_p
919	!!
920	!>\BRIEF give the data (real 3D) to the IOIPSL system (if we don't use XIOS).
921	!!
922	!! DESCRIPTION: Need to be call by all process
923	!!
924	!! \n
925	!_ ==============================================================================================================================
926	SUBROUTINE histwrite_r3d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
927	IMPLICIT NONE
928	!-
929	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
930	REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata
931	CHARACTER(LEN=*),INTENT(IN) :: pvarname
932
933	STOP 2
934
935	END SUBROUTINE histwrite_r3d_p
936
937
938	END MODULE ioipsl_para

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

Download in other formats: