Context Navigation

source: branches/ORCHIDEE_2_2/ORCHIDEE/src_parallel/ioipsl_para.f90 @ 6144

Last change on this file since 6144 was 5811, checked in by josefine.ghattas, 6 years ago

Corrections for unstructured grid:

one interface restput where wrong
interpolation to regular grid has been changed

Meurdesoif

Property svn:keywords set to HeadURL Date Author Revision

File size: 34.5 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
510	USE grid, ONLY : grid_type, unstructured, ind_cell_glo
511	IMPLICIT NONE
512	!-
513	INTEGER :: fid
514	CHARACTER(LEN=*) :: vname_q
515	INTEGER :: iim, jjm, llm, itau
516	LOGICAL def_beha
517	REAL :: var(:)
518	CHARACTER(LEN=*) :: MY_OPERATOR
519	INTEGER :: nbindex, ijndex(nbindex)
520	!-----------------------------
521	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
522	INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo
523
524	IF (is_root_prc) THEN
525	ALLOCATE( temp_g(iimjjmllm) )
526	ELSE
527	ALLOCATE( temp_g(1) )
528	ENDIF
529
530	IF (grid_type==unstructured) THEN
531
532	IF (is_root_prc) ALLOCATE(ind_cell_glo_glo(iim_g*jjm_g))
533	CALL gather_unindexed(ind_cell_glo,ind_cell_glo_glo)
534	IF (is_root_prc) CALL restget (fid, vname_q, iim, jjm, llm, itau, def_beha, &
535	temp_g, MY_OPERATOR, nbindex, ind_cell_glo_glo(ijndex(:)))
536
537	ELSE
538
539	IF (is_root_prc) CALL restget(fid, vname_q, iim, jjm, llm, itau, def_beha, &
540	temp_g, MY_OPERATOR, nbindex, ijndex)
541	ENDIF
542	CALL scatter(temp_g,var)
543	DEALLOCATE(temp_g)
544	END SUBROUTINE restget_p_opp_r1d
545
546	!! =============================================================================================================================
547	!! SUBROUTINE: restget_p_opp_r2d
548	!!
549	!>\BRIEF Transform the data (real 2D) from the restart file onto the model grid with the operation MY_OPERATOR
550	!!
551	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
552	!!
553	!! \n
554	!_ ==============================================================================================================================
555	SUBROUTINE restget_p_opp_r2d &
556	(fid, vname_q, iim, jjm, llm, itau, def_beha, &
557	var, MY_OPERATOR, nbindex, ijndex)
558
559	USE grid, ONLY : grid_type, unstructured, ind_cell_glo
560	IMPLICIT NONE
561	!-
562	INTEGER :: fid
563	CHARACTER(LEN=*) :: vname_q
564	INTEGER :: iim, jjm, llm, itau
565	LOGICAL def_beha
566	REAL :: var(:,:)
567	CHARACTER(LEN=*) :: MY_OPERATOR
568	INTEGER :: nbindex, ijndex(nbindex)
569	!-----------------------------
570	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
571	INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo
572
573	IF (is_root_prc) THEN
574	ALLOCATE( temp_g(iim,jjm) )
575	ELSE
576	ALLOCATE( temp_g(1,1) )
577	ENDIF
578
579	IF (grid_type==unstructured) THEN
580	IF (is_root_prc) ALLOCATE(ind_cell_glo_glo(iim_g*jjm_g))
581	CALL gather_unindexed(ind_cell_glo,ind_cell_glo_glo)
582	IF (is_root_prc) CALL restget (fid, vname_q, iim, jjm, llm, itau, def_beha, &
583	temp_g, MY_OPERATOR, nbindex, ind_cell_glo_glo(ijndex(:)))
584
585	ELSE
586
587	IF (is_root_prc) CALL restget(fid, vname_q, iim, jjm, llm, itau, def_beha, &
588	temp_g, MY_OPERATOR, nbindex, ijndex)
589	ENDIF
590	CALL scatter(temp_g,var)
591	DEALLOCATE(temp_g)
592	END SUBROUTINE restget_p_opp_r2d
593
594	!! =============================================================================================================================
595	!! SUBROUTINE: restget_p_r1d
596	!!
597	!>\BRIEF Transform the data (real 1D) from the restart file onto the model grid
598	!!
599	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
600	!! \n
601	!_ ==============================================================================================================================
602	SUBROUTINE restget_p_r1d &
603	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
604	! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
605	IMPLICIT NONE
606	!-
607	INTEGER :: fid
608	CHARACTER(LEN=*) :: vname_q
609	INTEGER :: iim, jjm, llm, itau
610	LOGICAL :: def_beha
611	REAL :: var(:)
612	!-------------------------
613	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
614
615	IF (is_root_prc) THEN
616	ALLOCATE( temp_g(iimjjmllm) )
617	ELSE
618	ALLOCATE( temp_g(1) )
619	ENDIF
620
621	IF (is_root_prc) THEN
622	CALL restget &
623	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
624	ENDIF
625	CALL scatter(temp_g,var)
626	DEALLOCATE(temp_g)
627	END SUBROUTINE restget_p_r1d
628
629	!! =============================================================================================================================
630	!! SUBROUTINE: restget_p_r2d
631	!!
632	!>\BRIEF Transform the data (real 2D) from the restart file onto the model grid
633	!!
634	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
635	!! \n
636	!_ ==============================================================================================================================
637	SUBROUTINE restget_p_r2d &
638	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
639	IMPLICIT NONE
640	!-
641	INTEGER :: fid
642	CHARACTER(LEN=*) :: vname_q
643	INTEGER :: iim, jjm, llm, itau
644	LOGICAL :: def_beha
645	REAL :: var(:,:)
646	!-------------------------
647	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
648
649	IF (is_root_prc) THEN
650	ALLOCATE( temp_g(iim,jjm) )
651	ELSE
652	ALLOCATE( temp_g(1,1) )
653	ENDIF
654	IF (is_root_prc) THEN
655	CALL restget &
656	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
657	ENDIF
658	CALL scatter(temp_g,var)
659	DEALLOCATE(temp_g)
660	END SUBROUTINE restget_p_r2d
661
662	!! =============================================================================================================================
663	!! SUBROUTINE: restget_p_r3d
664	!!
665	!>\BRIEF Transform the data (real 3D) from the restart file onto the model grid
666	!!
667	!! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process
668	!! \n
669	!_ ==============================================================================================================================
670	SUBROUTINE restget_p_r3d &
671	(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
672	IMPLICIT NONE
673	!-
674	INTEGER :: fid
675	CHARACTER(LEN=*) :: vname_q
676	INTEGER :: iim, jjm, llm, itau
677	LOGICAL def_beha
678	REAL :: var(:,:,:)
679	!-------------------------
680	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
681
682	IF (is_root_prc) THEN
683	ALLOCATE( temp_g(iim,jjm,llm) )
684	ELSE
685	ALLOCATE( temp_g(1,1,1) )
686	ENDIF
687
688	IF (is_root_prc) THEN
689	CALL restget &
690	(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
691	ENDIF
692	CALL scatter(temp_g,var)
693	DEALLOCATE(temp_g)
694	END SUBROUTINE restget_p_r3d
695
696	!! =============================================================================================================================
697	!! SUBROUTINE: restput_p_opp_r1d
698	!!
699	!>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file with the operation MY_OPERATOR
700	!!
701	!! DESCRIPTION: Need to be call by all process
702	!! \n
703	!_ ==============================================================================================================================
704	SUBROUTINE restput_p_opp_r1d &
705	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
706
707	USE grid, ONLY : grid_type, unstructured, ind_cell_glo
708	IMPLICIT NONE
709	!-
710	INTEGER :: fid
711	CHARACTER(LEN=*) :: vname_q
712	INTEGER :: iim, jjm, llm, itau
713	REAL :: var(:)
714	CHARACTER(LEN=*) :: MY_OPERATOR
715	INTEGER :: nbindex, ijndex(nbindex)
716	!-----------------------------
717	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
718	INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo
719
720	IF (is_root_prc) THEN
721	ALLOCATE( temp_g(iimjjmllm) )
722	ELSE
723	ALLOCATE ( temp_g(1) )
724	ENDIF
725
726	CALL gather(var,temp_g)
727
728	IF (grid_type==unstructured) THEN
729	IF (is_root_prc) ALLOCATE(ind_cell_glo_glo(iim_g*jjm_g))
730	CALL gather_unindexed(ind_cell_glo,ind_cell_glo_glo)
731	IF (is_root_prc) CALL restput(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, &
732	nbindex, ind_cell_glo_glo(ijndex(:)))
733	ELSE
734	IF (is_root_prc) CALL restput &
735	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
736	ENDIF
737
738	DEALLOCATE( temp_g )
739
740	END SUBROUTINE restput_p_opp_r1d
741
742	!! =============================================================================================================================
743	!! SUBROUTINE: restput_p_opp_r2d
744	!!
745	!>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file with the operation MY_OPERATOR
746	!!
747	!! DESCRIPTION: Need to be call by all process
748	!! \n
749	!_ ==============================================================================================================================
750	SUBROUTINE restput_p_opp_r2d &
751	(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
752
753	USE grid, ONLY : grid_type, unstructured, ind_cell_glo
754	IMPLICIT NONE
755	!-
756	INTEGER :: fid
757	CHARACTER(LEN=*) :: vname_q
758	INTEGER :: iim, jjm, llm, itau
759	REAL :: var(:,:)
760	CHARACTER(LEN=*) :: MY_OPERATOR
761	INTEGER :: nbindex, ijndex(nbindex)
762	!-----------------------------
763	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
764	INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo
765
766	IF (is_root_prc) THEN
767	ALLOCATE( temp_g(iim,jjm) )
768	ELSE
769	ALLOCATE( temp_g(1,1) )
770	ENDIF
771
772	CALL gather(var,temp_g)
773	IF (grid_type==unstructured) THEN
774	IF (is_root_prc) ALLOCATE(ind_cell_glo_glo(iim_g*jjm_g))
775	CALL gather_unindexed(ind_cell_glo,ind_cell_glo_glo)
776	IF (is_root_prc) CALL restput(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, &
777	nbindex, ind_cell_glo_glo(ijndex(:)))
778	ELSE
779	IF (is_root_prc) CALL restput &
780	(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
781	ENDIF
782	DEALLOCATE( temp_g )
783
784	END SUBROUTINE restput_p_opp_r2d
785
786	!! =============================================================================================================================
787	!! SUBROUTINE: restput_p_r1d
788	!!
789	!>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file
790	!!
791	!! DESCRIPTION: Need to be call by all process
792	!!
793	!! \n
794	!_ ==============================================================================================================================
795	SUBROUTINE restput_p_r1d (fid,vname_q,iim,jjm,llm,itau,var)
796	IMPLICIT NONE
797	!-
798	INTEGER :: fid
799	CHARACTER(LEN=*) :: vname_q
800	INTEGER :: iim, jjm, llm, itau
801	REAL :: var(:)
802	!-----------------------------
803	REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
804
805	IF (is_root_prc) THEN
806	ALLOCATE( temp_g(iimjjmllm) )
807	ELSE
808	ALLOCATE( temp_g(1) )
809	ENDIF
810
811	CALL gather(var,temp_g)
812	IF (is_root_prc) THEN
813	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
814	ENDIF
815	DEALLOCATE( temp_g )
816
817	END SUBROUTINE restput_p_r1d
818
819	!! =============================================================================================================================
820	!! SUBROUTINE: restput_p_r2d
821	!!
822	!>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file
823	!!
824	!! DESCRIPTION: Need to be call by all process
825	!!
826	!! \n
827	!_ ==============================================================================================================================
828	SUBROUTINE restput_p_r2d (fid,vname_q,iim,jjm,llm,itau,var)
829	IMPLICIT NONE
830	!-
831	INTEGER :: fid
832	CHARACTER(LEN=*) :: vname_q
833	INTEGER :: iim, jjm, llm, itau
834	REAL :: var(:,:)
835	!-------------------------
836	REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
837
838	IF (is_root_prc) THEN
839	ALLOCATE( temp_g(iim,jjm) )
840	ELSE
841	ALLOCATE( temp_g(1,1) )
842	ENDIF
843
844	CALL gather(var,temp_g)
845	IF (is_root_prc) THEN
846	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
847	ENDIF
848	DEALLOCATE( temp_g )
849
850	END SUBROUTINE restput_p_r2d
851
852	!! =============================================================================================================================
853	!! SUBROUTINE: restput_p_r3d
854	!!
855	!>\BRIEF allows to re-index data (real 3D) onto the original grid of the restart file
856	!!
857	!! DESCRIPTION: Need to be call by all process
858	!!
859	!! \n
860	!_ ==============================================================================================================================
861	SUBROUTINE restput_p_r3d (fid,vname_q,iim,jjm,llm,itau,var)
862	IMPLICIT NONE
863	!-
864	INTEGER :: fid
865	CHARACTER(LEN=*) :: vname_q
866	INTEGER :: iim, jjm, llm, itau
867	REAL :: var(:,:,:)
868	!-------------------------
869	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
870
871	IF (is_root_prc) THEN
872	ALLOCATE( temp_g(iim,jjm,llm) )
873	ELSE
874	ALLOCATE( temp_g(iim,jjm,llm) )
875	ENDIF
876
877	CALL gather(var,temp_g)
878	IF (is_root_prc) THEN
879	CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
880	ENDIF
881	DEALLOCATE( temp_g )
882
883	END SUBROUTINE restput_p_r3d
884
885	!! =============================================================================================================================
886	!! SUBROUTINE: histwrite_r1d_p
887	!!
888	!>\BRIEF give the data (real 1D) to the IOIPSL system (if we don't use XIOS).
889	!!
890	!! DESCRIPTION: Need to be call by all process
891	!!
892	!! \n
893	!_ ==============================================================================================================================
894	SUBROUTINE histwrite_r1d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
895	IMPLICIT NONE
896	!-
897	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
898	REAL,DIMENSION(:),INTENT(IN) :: pdata
899	CHARACTER(LEN=*),INTENT(IN) :: pvarname
900
901	REAL,DIMENSION(nbp_mpi) :: pdata_mpi
902
903	IF (pfileid > 0) THEN
904	! Continue only if the file is initilalized
905	CALL gather_omp(pdata,pdata_mpi)
906	IF (is_omp_root) THEN
907	CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpi,kindex_mpi)
908	ENDIF
909	END IF
910
911	END SUBROUTINE histwrite_r1d_p
912
913	!! =============================================================================================================================
914	!! SUBROUTINE: histwrite_r2d_p
915	!!
916	!>\BRIEF give the data (real 2D) to the IOIPSL system (if we don't use XIOS).
917	!!
918	!! DESCRIPTION: Need to be call by all process
919	!!
920	!! \n
921	!_ ==============================================================================================================================
922	SUBROUTINE histwrite_r2d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
923	IMPLICIT NONE
924	!-
925	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
926	REAL,DIMENSION(:,:),INTENT(IN) :: pdata
927	CHARACTER(LEN=*),INTENT(IN) :: pvarname
928
929	IF (pfileid > 0) THEN
930	! Continue only if the file is initilalized
931	CALL body(size(pdata,2),nindex)
932	END IF
933
934	CONTAINS
935
936	SUBROUTINE body(dim,nindex)
937	INTEGER :: dim
938	INTEGER :: nindex(nbp_omp,dim)
939
940	INTEGER :: nindex_mpi(nbp_mpi,dim)
941	REAL :: pdata_mpi(nbp_mpi,dim)
942
943	CALL gather_omp(pdata,pdata_mpi)
944	CALL gather_omp(nindex,nindex_mpi)
945
946	IF (is_omp_root) THEN
947	CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpidim,reshape(nindex_mpi,(/nbp_mpidim/)))
948	ENDIF
949	END SUBROUTINE body
950
951	END SUBROUTINE histwrite_r2d_p
952
953	!! =============================================================================================================================
954	!! SUBROUTINE: histwrite_r3d_p
955	!!
956	!>\BRIEF give the data (real 3D) to the IOIPSL system (if we don't use XIOS).
957	!!
958	!! DESCRIPTION: Need to be call by all process
959	!!
960	!! \n
961	!_ ==============================================================================================================================
962	SUBROUTINE histwrite_r3d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex)
963	IMPLICIT NONE
964	!-
965	INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex)
966	REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata
967	CHARACTER(LEN=*),INTENT(IN) :: pvarname
968
969	STOP 2
970
971	END SUBROUTINE histwrite_r3d_p
972
973
974	END MODULE ioipsl_para

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

Download in other formats: