1 | ! ============================================================================================================================== |
---|
2 | ! MODULE : ioipls_para |
---|
3 | ! |
---|
4 | ! CONTACT : orchidee-help _at_ listes.ipsl.fr |
---|
5 | ! |
---|
6 | ! LICENCE : IPSL (2006) |
---|
7 | ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC |
---|
8 | ! |
---|
9 | !>\BRIEF Overlap of IOIPSL functions for specific parallel use in ORCHIDEE. |
---|
10 | !! |
---|
11 | !!\n DESCRIPTION: This module contains interfaces for some IOIPSL subroutines adapted to be used in parallel mode by ORCHIDEE. |
---|
12 | !! |
---|
13 | !! Following interfaces are available : |
---|
14 | !! - getin_p : Read a variable from run.def file. The master process will call getin in IOIPSL. |
---|
15 | !! The same result will be known by all processes after the call. |
---|
16 | !! The variable can be an integer, real, logical or character string. It can be a scalar or |
---|
17 | !! have 1 or 2 dimensions except for character string which can only be scalar or have 1 dimension. |
---|
18 | !! - restget_p : Read a variable from restart file. The master process will call the subroutine restget in IOIPSL. |
---|
19 | !! The variable will be distributed on the local domain for each process. |
---|
20 | !! The variable must be a real and can have 1, 2 or 3 dimensions. It can not be a scalar. |
---|
21 | !! - restput_p : Write a variable to restart file. The master process will call the subroutine restput in IOIPSL. |
---|
22 | !! The input variable must be given on the local domain for each process. |
---|
23 | !! The variable must be a real and can have 1, 2 or 3 dimensions. It can not be a scalar. |
---|
24 | !! - histwrite_p : Write a variable to history file. The master process will call the subroutine histwrite in IOIPSL. |
---|
25 | !! The input variable must be given on the local domain for each process. |
---|
26 | !! The variable must be a real and can have 1, 2 or 3 dimensions. It can not be a scalar. |
---|
27 | !! |
---|
28 | !! Note that these subroutines must be called by all MPI processes and all OMP thredds because they contain |
---|
29 | !! all a MPI blocker function. |
---|
30 | !! |
---|
31 | !! |
---|
32 | !! |
---|
33 | !! RECENT CHANGE(S): None |
---|
34 | !! |
---|
35 | !! REFERENCES(S) : None |
---|
36 | !! |
---|
37 | !! SVN : |
---|
38 | !! $HeadURL$ |
---|
39 | !! $Date$ |
---|
40 | !! $Revision$ |
---|
41 | !! \n |
---|
42 | !_ ================================================================================================================================ |
---|
43 | |
---|
44 | MODULE ioipsl_para |
---|
45 | USE ioipsl |
---|
46 | USE mod_orchidee_para_var |
---|
47 | USE mod_orchidee_transfert_para |
---|
48 | USE constantes_var, ONLY: val_exp |
---|
49 | !- |
---|
50 | IMPLICIT NONE |
---|
51 | |
---|
52 | INTEGER, SAVE :: orch_domain_id |
---|
53 | !- |
---|
54 | INTEGER :: orch_ipslout=6, orch_ilv_cur=0, orch_ilv_max=0 |
---|
55 | !$OMP THREADPRIVATE( orch_ipslout, orch_ilv_cur, orch_ilv_max ) |
---|
56 | |
---|
57 | !- |
---|
58 | !- |
---|
59 | #include "src_parallel.h" |
---|
60 | !- |
---|
61 | !! ============================================================================================================================== |
---|
62 | !! INTERFACE : getin_p |
---|
63 | !! |
---|
64 | !>\BRIEF interface to parallelize the call to getin in IOIPSL |
---|
65 | !! |
---|
66 | !! DESCRIPTION : get a variable from a text input file. Need to be call by all process |
---|
67 | !! |
---|
68 | !! \n |
---|
69 | !_ ================================================================================================================================ |
---|
70 | INTERFACE getin_p |
---|
71 | MODULE PROCEDURE getin_p_c,getin_p_c1, & |
---|
72 | getin_p_i,getin_p_i1,getin_p_i2,& |
---|
73 | getin_p_r,getin_p_r1,getin_p_r2,& |
---|
74 | getin_p_l,getin_p_l1,getin_p_l2 |
---|
75 | END INTERFACE |
---|
76 | !- |
---|
77 | !! ============================================================================================================================== |
---|
78 | !! INTERFACE : restput_p |
---|
79 | !! |
---|
80 | !>\BRIEF interface to parallelize the call to restput in IOIPSL |
---|
81 | !! |
---|
82 | !! DESCRIPTION : allows to re-index data onto the original grid of the restart file. Need to be call by all process |
---|
83 | !! |
---|
84 | !! \n |
---|
85 | !_ ================================================================================================================================ |
---|
86 | INTERFACE restput_p |
---|
87 | MODULE PROCEDURE & |
---|
88 | restput_p_r3d, restput_p_r2d, restput_p_r1d, & |
---|
89 | restput_p_opp_r2d, restput_p_opp_r1d, & |
---|
90 | restput_p_nogrid_r_scal, restput_p_nogrid_i_scal |
---|
91 | END INTERFACE |
---|
92 | !- |
---|
93 | !! ============================================================================================================================== |
---|
94 | !! INTERFACE : restget_p |
---|
95 | !! |
---|
96 | !>\BRIEF interface to parallelize the call to restget in IOIPSL |
---|
97 | !! |
---|
98 | !! DESCRIPTION : Transform the data from the restart file onto the model grid. |
---|
99 | !! |
---|
100 | !! \n |
---|
101 | !_ ================================================================================================================================ |
---|
102 | INTERFACE restget_p |
---|
103 | MODULE PROCEDURE & |
---|
104 | restget_p_r3d, restget_p_r2d, restget_p_r1d, & |
---|
105 | restget_p_opp_r2d, restget_p_opp_r1d, & |
---|
106 | restget_p_nogrid_r_scal, restget_p_nogrid_i_scal |
---|
107 | END INTERFACE |
---|
108 | |
---|
109 | !! ============================================================================================================================== |
---|
110 | !! INTERFACE : histwrite_p |
---|
111 | !! |
---|
112 | !>\BRIEF interface to parallelize the call to histwrite in IOIPSL |
---|
113 | !! |
---|
114 | !! DESCRIPTION : give the data to the IOIPSL system (if we don't use XIOS). Need to be call by all process |
---|
115 | !! |
---|
116 | !! \n |
---|
117 | !_ ================================================================================================================================ |
---|
118 | |
---|
119 | INTERFACE histwrite_p |
---|
120 | MODULE PROCEDURE & |
---|
121 | histwrite_r1d_p,histwrite_r2d_p,histwrite_r3d_p |
---|
122 | END INTERFACE |
---|
123 | |
---|
124 | CONTAINS |
---|
125 | |
---|
126 | |
---|
127 | !! ============================================================================================================================= |
---|
128 | !! SUBROUTINE: Init_ioipsl_para |
---|
129 | !! |
---|
130 | !>\BRIEF call to IOIPSL routine : flio_dom_set |
---|
131 | !! |
---|
132 | !! DESCRIPTION: will sets up the domain activity of IOIPSL. Need to be call by all process |
---|
133 | !! |
---|
134 | !! \n |
---|
135 | !_ ============================================================================================================================== |
---|
136 | |
---|
137 | SUBROUTINE Init_ioipsl_para |
---|
138 | |
---|
139 | IMPLICIT NONE |
---|
140 | |
---|
141 | INTEGER,DIMENSION(2) :: ddid |
---|
142 | INTEGER,DIMENSION(2) :: dsg |
---|
143 | INTEGER,DIMENSION(2) :: dsl |
---|
144 | INTEGER,DIMENSION(2) :: dpf |
---|
145 | INTEGER,DIMENSION(2) :: dpl |
---|
146 | INTEGER,DIMENSION(2) :: dhs |
---|
147 | INTEGER,DIMENSION(2) :: dhe |
---|
148 | |
---|
149 | IF (is_omp_root) THEN |
---|
150 | ddid=(/ 1,2 /) |
---|
151 | dsg=(/ iim_g, jjm_g /) |
---|
152 | dsl=(/ iim_g, jj_nb /) |
---|
153 | dpf=(/ 1,jj_begin /) |
---|
154 | dpl=(/ iim_g, jj_end /) |
---|
155 | dhs=(/ ii_begin-1,0 /) |
---|
156 | if (mpi_rank==mpi_size-1) then |
---|
157 | dhe=(/0,0/) |
---|
158 | else |
---|
159 | dhe=(/ iim_g-ii_end,0 /) |
---|
160 | endif |
---|
161 | |
---|
162 | call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & |
---|
163 | 'APPLE',orch_domain_id) |
---|
164 | ENDIF |
---|
165 | |
---|
166 | END SUBROUTINE Init_ioipsl_para |
---|
167 | |
---|
168 | !! ============================================================================================================================= |
---|
169 | !! SUBROUTINE: ioconf_setatt_p |
---|
170 | !! |
---|
171 | !>\BRIEF parallelisation of the call to IOIPSL routine ioconf_setatt |
---|
172 | !! |
---|
173 | !! DESCRIPTION: NONE |
---|
174 | !! |
---|
175 | !! \n |
---|
176 | !_ ============================================================================================================================== |
---|
177 | SUBROUTINE ioconf_setatt_p (attname,attvalue) |
---|
178 | !--------------------------------------------------------------------- |
---|
179 | IMPLICIT NONE |
---|
180 | !- |
---|
181 | CHARACTER(LEN=*), INTENT(in) :: attname,attvalue |
---|
182 | !--------------------------------------------------------------------- |
---|
183 | |
---|
184 | IF (is_root_prc) THEN |
---|
185 | CALL ioconf_setatt(attname,attvalue) |
---|
186 | ENDIF |
---|
187 | |
---|
188 | END SUBROUTINE ioconf_setatt_p |
---|
189 | |
---|
190 | !! ============================================================================================================================= |
---|
191 | !! SUBROUTINE: ipslnlf_p |
---|
192 | !! |
---|
193 | !>\BRIEF parallelisation of the call to IOIPSL routine ipslnlf |
---|
194 | !! |
---|
195 | !! DESCRIPTION: The "ipslnlf" routine allows to know and modify the current logical number for the messages. |
---|
196 | !! |
---|
197 | !! \n |
---|
198 | !_ ============================================================================================================================== |
---|
199 | SUBROUTINE ipslnlf_p (new_number,old_number) |
---|
200 | !!-------------------------------------------------------------------- |
---|
201 | !! The "ipslnlf" routine allows to know and modify |
---|
202 | !! the current logical number for the messages. |
---|
203 | !! |
---|
204 | !! SUBROUTINE ipslnlf (new_number,old_number) |
---|
205 | !! |
---|
206 | !! Optional INPUT argument |
---|
207 | !! |
---|
208 | !! (I) new_number : new logical number of the file |
---|
209 | !! |
---|
210 | !! Optional OUTPUT argument |
---|
211 | !! |
---|
212 | !! (I) old_number : current logical number of the file |
---|
213 | !!-------------------------------------------------------------------- |
---|
214 | IMPLICIT NONE |
---|
215 | !- |
---|
216 | INTEGER,OPTIONAL,INTENT(IN) :: new_number |
---|
217 | INTEGER,OPTIONAL,INTENT(OUT) :: old_number |
---|
218 | !--------------------------------------------------------------------- |
---|
219 | IF (PRESENT(old_number)) THEN |
---|
220 | #ifndef CPP_OMP |
---|
221 | CALL ipslnlf(old_number=orch_ipslout) |
---|
222 | #endif |
---|
223 | old_number = orch_ipslout |
---|
224 | ENDIF |
---|
225 | IF (PRESENT(new_number)) THEN |
---|
226 | orch_ipslout = new_number |
---|
227 | #ifndef CPP_OMP |
---|
228 | CALL ipslnlf(new_number=orch_ipslout) |
---|
229 | #endif |
---|
230 | ENDIF |
---|
231 | |
---|
232 | END SUBROUTINE ipslnlf_p |
---|
233 | |
---|
234 | !! ============================================================================================================================= |
---|
235 | !! SUBROUTINE: ipslerr_p |
---|
236 | !! |
---|
237 | !>\BRIEF allows to handle the messages to the user. |
---|
238 | !! |
---|
239 | !! DESCRIPTION: NONE |
---|
240 | !! |
---|
241 | !! \n |
---|
242 | !_ ============================================================================================================================== |
---|
243 | !=== |
---|
244 | SUBROUTINE ipslerr_p (plev,pcname,pstr1,pstr2,pstr3) |
---|
245 | !--------------------------------------------------------------------- |
---|
246 | !! The "ipslerr_p" routine |
---|
247 | !! allows to handle the messages to the user. |
---|
248 | !! |
---|
249 | !! parallel version of IOIPSL ipslerr |
---|
250 | !! |
---|
251 | !! INPUT |
---|
252 | !! |
---|
253 | !! plev : Category of message to be reported to the user |
---|
254 | !! 1 = Note to the user |
---|
255 | !! 2 = Warning to the user |
---|
256 | !! 3 = Fatal error |
---|
257 | !! pcname : Name of subroutine which has called ipslerr |
---|
258 | !! pstr1 |
---|
259 | !! pstr2 : Strings containing the explanations to the user |
---|
260 | !! pstr3 |
---|
261 | !--------------------------------------------------------------------- |
---|
262 | IMPLICIT NONE |
---|
263 | |
---|
264 | #ifdef CPP_PARA |
---|
265 | INCLUDE 'mpif.h' |
---|
266 | #endif |
---|
267 | |
---|
268 | INTEGER :: plev |
---|
269 | CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 |
---|
270 | |
---|
271 | CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & |
---|
272 | & (/ "NOTE TO THE USER FROM ROUTINE ", & |
---|
273 | & "WARNING FROM ROUTINE ", & |
---|
274 | & "FATAL ERROR FROM ROUTINE " /) |
---|
275 | INTEGER :: ierr |
---|
276 | !--------------------------------------------------------------------- |
---|
277 | IF ( (plev >= 1).AND.(plev <= 3) ) THEN |
---|
278 | orch_ilv_cur = plev |
---|
279 | orch_ilv_max = MAX(orch_ilv_max,plev) |
---|
280 | WRITE(orch_ipslout,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) |
---|
281 | WRITE(orch_ipslout,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3) |
---|
282 | ENDIF |
---|
283 | IF (plev == 3) THEN |
---|
284 | WRITE(orch_ipslout,'("Fatal error from ORCHIDEE. STOP in ipslerr_p with code")') |
---|
285 | ! Force to pring text output using FLUSH only if cpp flag CPP_FLUSH is set in arch-XXX.fcm |
---|
286 | #ifdef CPP_FLUSH |
---|
287 | CALL FLUSH(orch_ipslout) |
---|
288 | #endif |
---|
289 | |
---|
290 | #ifdef CPP_PARA |
---|
291 | CALL MPI_ABORT(MPI_COMM_WORLD, 1, ierr) |
---|
292 | #endif |
---|
293 | STOP 1 |
---|
294 | ENDIF |
---|
295 | !--------------------- |
---|
296 | END SUBROUTINE ipslerr_p |
---|
297 | |
---|
298 | |
---|
299 | !! ============================================================================================================================= |
---|
300 | !! SUBROUTINE: getin_p_c |
---|
301 | !! |
---|
302 | !>\BRIEF get a character variable in text input file |
---|
303 | !! |
---|
304 | !! DESCRIPTION: Need to be call by all process |
---|
305 | !! |
---|
306 | !! \n |
---|
307 | !_ ============================================================================================================================== |
---|
308 | SUBROUTINE getin_p_c(VarIn,VarOut) |
---|
309 | IMPLICIT NONE |
---|
310 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
311 | CHARACTER(LEN=*),INTENT(INOUT) :: VarOut |
---|
312 | |
---|
313 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
314 | CALL bcast(VarOut) |
---|
315 | END SUBROUTINE getin_p_c |
---|
316 | |
---|
317 | !! ============================================================================================================================= |
---|
318 | !! SUBROUTINE: getin_p_c1 |
---|
319 | !! |
---|
320 | !>\BRIEF get a character 1D array in text input file |
---|
321 | !! |
---|
322 | !! DESCRIPTION: Need to be call by all process |
---|
323 | !! |
---|
324 | !! \n |
---|
325 | !_ ============================================================================================================================== |
---|
326 | SUBROUTINE getin_p_c1(VarIn,VarOut) |
---|
327 | IMPLICIT NONE |
---|
328 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
329 | CHARACTER(LEN=*),INTENT(INOUT) :: VarOut(:) |
---|
330 | |
---|
331 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
332 | CALL bcast(VarOut) |
---|
333 | END SUBROUTINE getin_p_c1 |
---|
334 | |
---|
335 | !! ============================================================================================================================= |
---|
336 | !! SUBROUTINE: getin_p_i |
---|
337 | !! |
---|
338 | !>\BRIEF get an integer variable in text input file |
---|
339 | !! |
---|
340 | !! DESCRIPTION: Need to be call by all process |
---|
341 | !! |
---|
342 | !! \n |
---|
343 | !_ ============================================================================================================================== |
---|
344 | SUBROUTINE getin_p_i(VarIn,VarOut) |
---|
345 | IMPLICIT NONE |
---|
346 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
347 | INTEGER,INTENT(INOUT) :: VarOut |
---|
348 | |
---|
349 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
350 | CALL bcast(VarOut) |
---|
351 | END SUBROUTINE getin_p_i |
---|
352 | |
---|
353 | !! ============================================================================================================================= |
---|
354 | !! SUBROUTINE: getin_p_i1 |
---|
355 | !! |
---|
356 | !>\BRIEF get an integer 1D array in text input file |
---|
357 | !! |
---|
358 | !! DESCRIPTION: Need to be call by all process |
---|
359 | !! |
---|
360 | !! \n |
---|
361 | !_ ============================================================================================================================== |
---|
362 | SUBROUTINE getin_p_i1(VarIn,VarOut) |
---|
363 | IMPLICIT NONE |
---|
364 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
365 | INTEGER,INTENT(INOUT) :: VarOut(:) |
---|
366 | |
---|
367 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
368 | CALL bcast(VarOut) |
---|
369 | END SUBROUTINE getin_p_i1 |
---|
370 | |
---|
371 | !! ============================================================================================================================= |
---|
372 | !! SUBROUTINE: getin_p_i2 |
---|
373 | !! |
---|
374 | !>\BRIEF get an integer 2D array in text input file |
---|
375 | !! |
---|
376 | !! DESCRIPTION: Need to be call by all process |
---|
377 | !! |
---|
378 | !! \n |
---|
379 | !_ ============================================================================================================================== |
---|
380 | SUBROUTINE getin_p_i2(VarIn,VarOut) |
---|
381 | IMPLICIT NONE |
---|
382 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
383 | INTEGER,INTENT(INOUT) :: VarOut(:,:) |
---|
384 | |
---|
385 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
386 | CALL bcast(VarOut) |
---|
387 | END SUBROUTINE getin_p_i2 |
---|
388 | |
---|
389 | !! ============================================================================================================================= |
---|
390 | !! SUBROUTINE: getin_p_r |
---|
391 | !! |
---|
392 | !>\BRIEF get a float variable in text input file |
---|
393 | !! |
---|
394 | !! DESCRIPTION: Need to be call by all process |
---|
395 | !! |
---|
396 | !! \n |
---|
397 | !_ ============================================================================================================================== |
---|
398 | SUBROUTINE getin_p_r(VarIn,VarOut) |
---|
399 | IMPLICIT NONE |
---|
400 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
401 | REAL,INTENT(INOUT) :: VarOut |
---|
402 | |
---|
403 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
404 | CALL bcast(VarOut) |
---|
405 | END SUBROUTINE getin_p_r |
---|
406 | |
---|
407 | !! ============================================================================================================================= |
---|
408 | !! SUBROUTINE: getin_p_r1 |
---|
409 | !! |
---|
410 | !>\BRIEF get a float 1D array in text input file |
---|
411 | !! |
---|
412 | !! DESCRIPTION: Need to be call by all process |
---|
413 | !! |
---|
414 | !! \n |
---|
415 | !_ ============================================================================================================================== |
---|
416 | SUBROUTINE getin_p_r1(VarIn,VarOut) |
---|
417 | IMPLICIT NONE |
---|
418 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
419 | REAL,INTENT(INOUT) :: VarOut(:) |
---|
420 | |
---|
421 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
422 | CALL bcast(VarOut) |
---|
423 | END SUBROUTINE getin_p_r1 |
---|
424 | |
---|
425 | !! ============================================================================================================================= |
---|
426 | !! SUBROUTINE: getin_p_r2 |
---|
427 | !! |
---|
428 | !>\BRIEF get a float 2D array in text input file |
---|
429 | !! |
---|
430 | !! DESCRIPTION: Need to be call by all process |
---|
431 | !! |
---|
432 | !! \n |
---|
433 | !_ ============================================================================================================================== |
---|
434 | SUBROUTINE getin_p_r2(VarIn,VarOut) |
---|
435 | IMPLICIT NONE |
---|
436 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
437 | REAL,INTENT(INOUT) :: VarOut(:,:) |
---|
438 | |
---|
439 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
440 | CALL bcast(VarOut) |
---|
441 | END SUBROUTINE getin_p_r2 |
---|
442 | |
---|
443 | |
---|
444 | !! ============================================================================================================================= |
---|
445 | !! SUBROUTINE: getin_p_l |
---|
446 | !! |
---|
447 | !>\BRIEF get a logical variable in text input file |
---|
448 | !! |
---|
449 | !! DESCRIPTION: Need to be call by all process |
---|
450 | !! |
---|
451 | !! \n |
---|
452 | !_ ============================================================================================================================== |
---|
453 | SUBROUTINE getin_p_l(VarIn,VarOut) |
---|
454 | IMPLICIT NONE |
---|
455 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
456 | LOGICAL,INTENT(INOUT) :: VarOut |
---|
457 | |
---|
458 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
459 | CALL bcast(VarOut) |
---|
460 | END SUBROUTINE getin_p_l |
---|
461 | |
---|
462 | !! ============================================================================================================================= |
---|
463 | !! SUBROUTINE: getin_p_l1 |
---|
464 | !! |
---|
465 | !>\BRIEF get a logical 1D array in text input file |
---|
466 | !! |
---|
467 | !! DESCRIPTION: Need to be call by all process |
---|
468 | !! |
---|
469 | !! \n |
---|
470 | !_ ============================================================================================================================== |
---|
471 | SUBROUTINE getin_p_l1(VarIn,VarOut) |
---|
472 | IMPLICIT NONE |
---|
473 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
474 | LOGICAL,INTENT(INOUT) :: VarOut(:) |
---|
475 | |
---|
476 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
477 | CALL bcast(VarOut) |
---|
478 | END SUBROUTINE getin_p_l1 |
---|
479 | |
---|
480 | !! ============================================================================================================================= |
---|
481 | !! SUBROUTINE: getin_p_l2 |
---|
482 | !! |
---|
483 | !>\BRIEF get a logical 2D array in text input file |
---|
484 | !! |
---|
485 | !! DESCRIPTION: Need to be call by all process |
---|
486 | !! |
---|
487 | !! \n |
---|
488 | !_ ============================================================================================================================== |
---|
489 | SUBROUTINE getin_p_l2(VarIn,VarOut) |
---|
490 | IMPLICIT NONE |
---|
491 | CHARACTER(LEN=*),INTENT(IN) :: VarIn |
---|
492 | LOGICAL,INTENT(INOUT) :: VarOut(:,:) |
---|
493 | |
---|
494 | IF (is_root_prc) CALL getin(VarIn,VarOut) |
---|
495 | CALL bcast(VarOut) |
---|
496 | END SUBROUTINE getin_p_l2 |
---|
497 | !- |
---|
498 | |
---|
499 | !! ============================================================================================================================= |
---|
500 | !! SUBROUTINE: restget_p_opp_r1d |
---|
501 | !! |
---|
502 | !>\BRIEF Transform the data (real 1D) from the restart file onto the model grid with the operation MY_OPERATOR |
---|
503 | !! |
---|
504 | !! DESCRIPTION: do not use this function with non grid variable |
---|
505 | !! |
---|
506 | !! \n |
---|
507 | !_ ============================================================================================================================== |
---|
508 | SUBROUTINE restget_p_opp_r1d & |
---|
509 | (fid, vname_q, iim, jjm, llm, itau, def_beha, & |
---|
510 | var, MY_OPERATOR, nbindex, ijndex) |
---|
511 | ! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE ! |
---|
512 | |
---|
513 | USE grid, ONLY : grid_type, unstructured, ind_cell_glo |
---|
514 | IMPLICIT NONE |
---|
515 | !- |
---|
516 | INTEGER :: fid |
---|
517 | CHARACTER(LEN=*) :: vname_q |
---|
518 | INTEGER :: iim, jjm, llm, itau |
---|
519 | LOGICAL def_beha |
---|
520 | REAL :: var(:) |
---|
521 | CHARACTER(LEN=*) :: MY_OPERATOR |
---|
522 | INTEGER :: nbindex, ijndex(nbindex) |
---|
523 | !----------------------------- |
---|
524 | REAL, ALLOCATABLE, DIMENSION(:) :: temp_g |
---|
525 | INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo |
---|
526 | |
---|
527 | IF (is_root_prc) THEN |
---|
528 | ALLOCATE( temp_g(iim*jjm*llm) ) |
---|
529 | ELSE |
---|
530 | ALLOCATE( temp_g(1) ) |
---|
531 | ENDIF |
---|
532 | |
---|
533 | IF (grid_type==unstructured) THEN |
---|
534 | |
---|
535 | IF (is_root_prc) THEN |
---|
536 | ALLOCATE(ind_cell_glo_glo(iim_g*jjm_g)) |
---|
537 | ELSE |
---|
538 | ALLOCATE(ind_cell_glo_glo(1)) |
---|
539 | ENDIF |
---|
540 | CALL gather_unindexed(ind_cell_glo,ind_cell_glo_glo) |
---|
541 | IF (is_root_prc) CALL restget (fid, vname_q, iim, jjm, llm, itau, def_beha, & |
---|
542 | temp_g, MY_OPERATOR, nbindex, ind_cell_glo_glo(ijndex(:))) |
---|
543 | |
---|
544 | ELSE |
---|
545 | |
---|
546 | IF (is_root_prc) CALL restget(fid, vname_q, iim, jjm, llm, itau, def_beha, & |
---|
547 | temp_g, MY_OPERATOR, nbindex, ijndex) |
---|
548 | ENDIF |
---|
549 | CALL scatter(temp_g,var) |
---|
550 | DEALLOCATE(temp_g) |
---|
551 | END SUBROUTINE restget_p_opp_r1d |
---|
552 | |
---|
553 | !! ============================================================================================================================= |
---|
554 | !! SUBROUTINE: restget_p_opp_r2d |
---|
555 | !! |
---|
556 | !>\BRIEF Transform the data (real 2D) from the restart file onto the model grid with the operation MY_OPERATOR |
---|
557 | !! |
---|
558 | !! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process |
---|
559 | !! |
---|
560 | !! \n |
---|
561 | !_ ============================================================================================================================== |
---|
562 | SUBROUTINE restget_p_opp_r2d & |
---|
563 | (fid, vname_q, iim, jjm, llm, itau, def_beha, & |
---|
564 | var, MY_OPERATOR, nbindex, ijndex) |
---|
565 | |
---|
566 | USE grid, ONLY : grid_type, unstructured, ind_cell_glo |
---|
567 | IMPLICIT NONE |
---|
568 | !- |
---|
569 | INTEGER :: fid |
---|
570 | CHARACTER(LEN=*) :: vname_q |
---|
571 | INTEGER :: iim, jjm, llm, itau |
---|
572 | LOGICAL def_beha |
---|
573 | REAL :: var(:,:) |
---|
574 | CHARACTER(LEN=*) :: MY_OPERATOR |
---|
575 | INTEGER :: nbindex, ijndex(nbindex) |
---|
576 | !----------------------------- |
---|
577 | REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g |
---|
578 | INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo |
---|
579 | |
---|
580 | IF (is_root_prc) THEN |
---|
581 | ALLOCATE( temp_g(iim,jjm) ) |
---|
582 | ELSE |
---|
583 | ALLOCATE( temp_g(1,1) ) |
---|
584 | ENDIF |
---|
585 | |
---|
586 | IF (grid_type==unstructured) THEN |
---|
587 | IF (is_root_prc) THEN |
---|
588 | ALLOCATE(ind_cell_glo_glo(iim_g*jjm_g)) |
---|
589 | ELSE |
---|
590 | ALLOCATE(ind_cell_glo_glo(1)) |
---|
591 | ENDIF |
---|
592 | CALL gather_unindexed(ind_cell_glo,ind_cell_glo_glo) |
---|
593 | IF (is_root_prc) CALL restget (fid, vname_q, iim, jjm, llm, itau, def_beha, & |
---|
594 | temp_g, MY_OPERATOR, nbindex, ind_cell_glo_glo(ijndex(:))) |
---|
595 | |
---|
596 | ELSE |
---|
597 | |
---|
598 | IF (is_root_prc) CALL restget(fid, vname_q, iim, jjm, llm, itau, def_beha, & |
---|
599 | temp_g, MY_OPERATOR, nbindex, ijndex) |
---|
600 | ENDIF |
---|
601 | CALL scatter(temp_g,var) |
---|
602 | DEALLOCATE(temp_g) |
---|
603 | END SUBROUTINE restget_p_opp_r2d |
---|
604 | |
---|
605 | !! ============================================================================================================================= |
---|
606 | !! SUBROUTINE: restget_p_r1d |
---|
607 | !! |
---|
608 | !>\BRIEF Transform the data (real 1D) from the restart file onto the model grid |
---|
609 | !! |
---|
610 | !! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process |
---|
611 | !! \n |
---|
612 | !_ ============================================================================================================================== |
---|
613 | SUBROUTINE restget_p_r1d & |
---|
614 | (fid,vname_q,iim,jjm,llm,itau,def_beha,var) |
---|
615 | ! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE ! |
---|
616 | IMPLICIT NONE |
---|
617 | !- |
---|
618 | INTEGER :: fid |
---|
619 | CHARACTER(LEN=*) :: vname_q |
---|
620 | INTEGER :: iim, jjm, llm, itau |
---|
621 | LOGICAL :: def_beha |
---|
622 | REAL :: var(:) |
---|
623 | !------------------------- |
---|
624 | REAL, ALLOCATABLE, DIMENSION(:) :: temp_g |
---|
625 | |
---|
626 | IF (is_root_prc) THEN |
---|
627 | ALLOCATE( temp_g(iim*jjm*llm) ) |
---|
628 | ELSE |
---|
629 | ALLOCATE( temp_g(1) ) |
---|
630 | ENDIF |
---|
631 | |
---|
632 | IF (is_root_prc) THEN |
---|
633 | CALL restget & |
---|
634 | (fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g) |
---|
635 | ENDIF |
---|
636 | CALL scatter(temp_g,var) |
---|
637 | DEALLOCATE(temp_g) |
---|
638 | END SUBROUTINE restget_p_r1d |
---|
639 | |
---|
640 | !! ============================================================================================================================= |
---|
641 | !! SUBROUTINE: restget_p_r2d |
---|
642 | !! |
---|
643 | !>\BRIEF Transform the data (real 2D) from the restart file onto the model grid |
---|
644 | !! |
---|
645 | !! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process |
---|
646 | !! \n |
---|
647 | !_ ============================================================================================================================== |
---|
648 | SUBROUTINE restget_p_r2d & |
---|
649 | (fid,vname_q,iim,jjm,llm,itau,def_beha,var) |
---|
650 | IMPLICIT NONE |
---|
651 | !- |
---|
652 | INTEGER :: fid |
---|
653 | CHARACTER(LEN=*) :: vname_q |
---|
654 | INTEGER :: iim, jjm, llm, itau |
---|
655 | LOGICAL :: def_beha |
---|
656 | REAL :: var(:,:) |
---|
657 | !------------------------- |
---|
658 | REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g |
---|
659 | |
---|
660 | IF (is_root_prc) THEN |
---|
661 | ALLOCATE( temp_g(iim,jjm) ) |
---|
662 | ELSE |
---|
663 | ALLOCATE( temp_g(1,1) ) |
---|
664 | ENDIF |
---|
665 | IF (is_root_prc) THEN |
---|
666 | CALL restget & |
---|
667 | (fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g) |
---|
668 | ENDIF |
---|
669 | CALL scatter(temp_g,var) |
---|
670 | DEALLOCATE(temp_g) |
---|
671 | END SUBROUTINE restget_p_r2d |
---|
672 | |
---|
673 | !! ============================================================================================================================= |
---|
674 | !! SUBROUTINE: restget_p_r3d |
---|
675 | !! |
---|
676 | !>\BRIEF Transform the data (real 3D) from the restart file onto the model grid |
---|
677 | !! |
---|
678 | !! DESCRIPTION: do not use this function with non grid variable. Need to be call by all process |
---|
679 | !! \n |
---|
680 | !_ ============================================================================================================================== |
---|
681 | SUBROUTINE restget_p_r3d & |
---|
682 | (fid,vname_q,iim,jjm,llm,itau,def_beha,var) |
---|
683 | IMPLICIT NONE |
---|
684 | !- |
---|
685 | INTEGER :: fid |
---|
686 | CHARACTER(LEN=*) :: vname_q |
---|
687 | INTEGER :: iim, jjm, llm, itau |
---|
688 | LOGICAL def_beha |
---|
689 | REAL :: var(:,:,:) |
---|
690 | !------------------------- |
---|
691 | REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g |
---|
692 | |
---|
693 | IF (is_root_prc) THEN |
---|
694 | ALLOCATE( temp_g(iim,jjm,llm) ) |
---|
695 | ELSE |
---|
696 | ALLOCATE( temp_g(1,1,1) ) |
---|
697 | ENDIF |
---|
698 | |
---|
699 | IF (is_root_prc) THEN |
---|
700 | CALL restget & |
---|
701 | (fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g) |
---|
702 | ENDIF |
---|
703 | CALL scatter(temp_g,var) |
---|
704 | DEALLOCATE(temp_g) |
---|
705 | END SUBROUTINE restget_p_r3d |
---|
706 | |
---|
707 | !! ============================================================================================================================= |
---|
708 | !! SUBROUTINE: restput_p_opp_r1d |
---|
709 | !! |
---|
710 | !>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file with the operation MY_OPERATOR |
---|
711 | !! |
---|
712 | !! DESCRIPTION: Need to be call by all process |
---|
713 | !! \n |
---|
714 | !_ ============================================================================================================================== |
---|
715 | SUBROUTINE restput_p_opp_r1d & |
---|
716 | (fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex) |
---|
717 | |
---|
718 | USE grid, ONLY : grid_type, unstructured, ind_cell_glo |
---|
719 | IMPLICIT NONE |
---|
720 | !- |
---|
721 | INTEGER :: fid |
---|
722 | CHARACTER(LEN=*) :: vname_q |
---|
723 | INTEGER :: iim, jjm, llm, itau |
---|
724 | REAL :: var(:) |
---|
725 | CHARACTER(LEN=*) :: MY_OPERATOR |
---|
726 | INTEGER :: nbindex, ijndex(nbindex) |
---|
727 | !----------------------------- |
---|
728 | REAL, ALLOCATABLE, DIMENSION(:) :: temp_g |
---|
729 | INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo |
---|
730 | |
---|
731 | IF (is_root_prc) THEN |
---|
732 | ALLOCATE( temp_g(iim*jjm*llm) ) |
---|
733 | ELSE |
---|
734 | ALLOCATE ( temp_g(1) ) |
---|
735 | ENDIF |
---|
736 | |
---|
737 | CALL gather(var,temp_g) |
---|
738 | |
---|
739 | IF (grid_type==unstructured) THEN |
---|
740 | IF (is_root_prc) THEN |
---|
741 | ALLOCATE(ind_cell_glo_glo(iim_g*jjm_g)) |
---|
742 | ELSE |
---|
743 | ALLOCATE(ind_cell_glo_glo(1)) |
---|
744 | ENDIF |
---|
745 | CALL gather_unindexed(ind_cell_glo,ind_cell_glo_glo) |
---|
746 | IF (is_root_prc) CALL restput(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, & |
---|
747 | nbindex, ind_cell_glo_glo(ijndex(:))) |
---|
748 | ELSE |
---|
749 | IF (is_root_prc) CALL restput & |
---|
750 | (fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex) |
---|
751 | ENDIF |
---|
752 | |
---|
753 | DEALLOCATE( temp_g ) |
---|
754 | |
---|
755 | END SUBROUTINE restput_p_opp_r1d |
---|
756 | |
---|
757 | !! ============================================================================================================================= |
---|
758 | !! SUBROUTINE: restput_p_opp_r2d |
---|
759 | !! |
---|
760 | !>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file with the operation MY_OPERATOR |
---|
761 | !! |
---|
762 | !! DESCRIPTION: Need to be call by all process |
---|
763 | !! \n |
---|
764 | !_ ============================================================================================================================== |
---|
765 | SUBROUTINE restput_p_opp_r2d & |
---|
766 | (fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex) |
---|
767 | |
---|
768 | USE grid, ONLY : grid_type, unstructured, ind_cell_glo |
---|
769 | IMPLICIT NONE |
---|
770 | !- |
---|
771 | INTEGER :: fid |
---|
772 | CHARACTER(LEN=*) :: vname_q |
---|
773 | INTEGER :: iim, jjm, llm, itau |
---|
774 | REAL :: var(:,:) |
---|
775 | CHARACTER(LEN=*) :: MY_OPERATOR |
---|
776 | INTEGER :: nbindex, ijndex(nbindex) |
---|
777 | !----------------------------- |
---|
778 | REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g |
---|
779 | INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo |
---|
780 | |
---|
781 | IF (is_root_prc) THEN |
---|
782 | ALLOCATE( temp_g(iim,jjm) ) |
---|
783 | ELSE |
---|
784 | ALLOCATE( temp_g(1,1) ) |
---|
785 | ENDIF |
---|
786 | |
---|
787 | CALL gather(var,temp_g) |
---|
788 | IF (grid_type==unstructured) THEN |
---|
789 | IF (is_root_prc) THEN |
---|
790 | ALLOCATE(ind_cell_glo_glo(iim_g*jjm_g)) |
---|
791 | ELSE |
---|
792 | ALLOCATE(ind_cell_glo_glo(1)) |
---|
793 | ENDIF |
---|
794 | CALL gather_unindexed(ind_cell_glo,ind_cell_glo_glo) |
---|
795 | IF (is_root_prc) CALL restput(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, & |
---|
796 | nbindex, ind_cell_glo_glo(ijndex(:))) |
---|
797 | ELSE |
---|
798 | IF (is_root_prc) CALL restput & |
---|
799 | (fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex) |
---|
800 | ENDIF |
---|
801 | DEALLOCATE( temp_g ) |
---|
802 | |
---|
803 | END SUBROUTINE restput_p_opp_r2d |
---|
804 | |
---|
805 | !! ============================================================================================================================= |
---|
806 | !! SUBROUTINE: restput_p_r1d |
---|
807 | !! |
---|
808 | !>\BRIEF allows to re-index data (real 1D) onto the original grid of the restart file |
---|
809 | !! |
---|
810 | !! DESCRIPTION: Need to be call by all process |
---|
811 | !! |
---|
812 | !! \n |
---|
813 | !_ ============================================================================================================================== |
---|
814 | SUBROUTINE restput_p_r1d (fid,vname_q,iim,jjm,llm,itau,var) |
---|
815 | IMPLICIT NONE |
---|
816 | !- |
---|
817 | INTEGER :: fid |
---|
818 | CHARACTER(LEN=*) :: vname_q |
---|
819 | INTEGER :: iim, jjm, llm, itau |
---|
820 | REAL :: var(:) |
---|
821 | !----------------------------- |
---|
822 | REAL, ALLOCATABLE, DIMENSION(:) :: temp_g |
---|
823 | |
---|
824 | IF (is_root_prc) THEN |
---|
825 | ALLOCATE( temp_g(iim*jjm*llm) ) |
---|
826 | ELSE |
---|
827 | ALLOCATE( temp_g(1) ) |
---|
828 | ENDIF |
---|
829 | |
---|
830 | CALL gather(var,temp_g) |
---|
831 | IF (is_root_prc) THEN |
---|
832 | CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g) |
---|
833 | ENDIF |
---|
834 | DEALLOCATE( temp_g ) |
---|
835 | |
---|
836 | END SUBROUTINE restput_p_r1d |
---|
837 | |
---|
838 | !! ============================================================================================================================= |
---|
839 | !! SUBROUTINE: restput_p_r2d |
---|
840 | !! |
---|
841 | !>\BRIEF allows to re-index data (real 2D) onto the original grid of the restart file |
---|
842 | !! |
---|
843 | !! DESCRIPTION: Need to be call by all process |
---|
844 | !! |
---|
845 | !! \n |
---|
846 | !_ ============================================================================================================================== |
---|
847 | SUBROUTINE restput_p_r2d (fid,vname_q,iim,jjm,llm,itau,var) |
---|
848 | IMPLICIT NONE |
---|
849 | !- |
---|
850 | INTEGER :: fid |
---|
851 | CHARACTER(LEN=*) :: vname_q |
---|
852 | INTEGER :: iim, jjm, llm, itau |
---|
853 | REAL :: var(:,:) |
---|
854 | !------------------------- |
---|
855 | REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g |
---|
856 | |
---|
857 | IF (is_root_prc) THEN |
---|
858 | ALLOCATE( temp_g(iim,jjm) ) |
---|
859 | ELSE |
---|
860 | ALLOCATE( temp_g(1,1) ) |
---|
861 | ENDIF |
---|
862 | |
---|
863 | CALL gather(var,temp_g) |
---|
864 | IF (is_root_prc) THEN |
---|
865 | CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g) |
---|
866 | ENDIF |
---|
867 | DEALLOCATE( temp_g ) |
---|
868 | |
---|
869 | END SUBROUTINE restput_p_r2d |
---|
870 | |
---|
871 | !! ============================================================================================================================= |
---|
872 | !! SUBROUTINE: restput_p_r3d |
---|
873 | !! |
---|
874 | !>\BRIEF allows to re-index data (real 3D) onto the original grid of the restart file |
---|
875 | !! |
---|
876 | !! DESCRIPTION: Need to be call by all process |
---|
877 | !! |
---|
878 | !! \n |
---|
879 | !_ ============================================================================================================================== |
---|
880 | SUBROUTINE restput_p_r3d (fid,vname_q,iim,jjm,llm,itau,var) |
---|
881 | IMPLICIT NONE |
---|
882 | !- |
---|
883 | INTEGER :: fid |
---|
884 | CHARACTER(LEN=*) :: vname_q |
---|
885 | INTEGER :: iim, jjm, llm, itau |
---|
886 | REAL :: var(:,:,:) |
---|
887 | !------------------------- |
---|
888 | REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g |
---|
889 | |
---|
890 | IF (is_root_prc) THEN |
---|
891 | ALLOCATE( temp_g(iim,jjm,llm) ) |
---|
892 | ELSE |
---|
893 | ALLOCATE( temp_g(iim,jjm,llm) ) |
---|
894 | ENDIF |
---|
895 | |
---|
896 | CALL gather(var,temp_g) |
---|
897 | IF (is_root_prc) THEN |
---|
898 | CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g) |
---|
899 | ENDIF |
---|
900 | DEALLOCATE( temp_g ) |
---|
901 | |
---|
902 | END SUBROUTINE restput_p_r3d |
---|
903 | |
---|
904 | !! ============================================================================================================================= |
---|
905 | !! SUBROUTINE: histwrite_r1d_p |
---|
906 | !! |
---|
907 | !>\BRIEF give the data (real 1D) to the IOIPSL system (if we don't use XIOS). |
---|
908 | !! |
---|
909 | !! DESCRIPTION: Need to be call by all process |
---|
910 | !! |
---|
911 | !! \n |
---|
912 | !_ ============================================================================================================================== |
---|
913 | SUBROUTINE histwrite_r1d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex) |
---|
914 | IMPLICIT NONE |
---|
915 | !- |
---|
916 | INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex) |
---|
917 | REAL,DIMENSION(:),INTENT(IN) :: pdata |
---|
918 | CHARACTER(LEN=*),INTENT(IN) :: pvarname |
---|
919 | |
---|
920 | REAL,DIMENSION(nbp_mpi) :: pdata_mpi |
---|
921 | |
---|
922 | IF (pfileid > 0) THEN |
---|
923 | ! Continue only if the file is initilalized |
---|
924 | CALL gather_omp(pdata,pdata_mpi) |
---|
925 | IF (is_omp_root) THEN |
---|
926 | CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpi,kindex_mpi) |
---|
927 | ENDIF |
---|
928 | END IF |
---|
929 | |
---|
930 | END SUBROUTINE histwrite_r1d_p |
---|
931 | |
---|
932 | !! ============================================================================================================================= |
---|
933 | !! SUBROUTINE: histwrite_r2d_p |
---|
934 | !! |
---|
935 | !>\BRIEF give the data (real 2D) to the IOIPSL system (if we don't use XIOS). |
---|
936 | !! |
---|
937 | !! DESCRIPTION: Need to be call by all process |
---|
938 | !! |
---|
939 | !! \n |
---|
940 | !_ ============================================================================================================================== |
---|
941 | SUBROUTINE histwrite_r2d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex) |
---|
942 | IMPLICIT NONE |
---|
943 | !- |
---|
944 | INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex) |
---|
945 | REAL,DIMENSION(:,:),INTENT(IN) :: pdata |
---|
946 | CHARACTER(LEN=*),INTENT(IN) :: pvarname |
---|
947 | |
---|
948 | IF (pfileid > 0) THEN |
---|
949 | ! Continue only if the file is initilalized |
---|
950 | CALL body(size(pdata,2),nindex) |
---|
951 | END IF |
---|
952 | |
---|
953 | CONTAINS |
---|
954 | |
---|
955 | SUBROUTINE body(dim,nindex) |
---|
956 | INTEGER :: dim |
---|
957 | INTEGER :: nindex(nbp_omp,dim) |
---|
958 | |
---|
959 | INTEGER :: nindex_mpi(nbp_mpi,dim) |
---|
960 | REAL :: pdata_mpi(nbp_mpi,dim) |
---|
961 | |
---|
962 | CALL gather_omp(pdata,pdata_mpi) |
---|
963 | CALL gather_omp(nindex,nindex_mpi) |
---|
964 | |
---|
965 | IF (is_omp_root) THEN |
---|
966 | CALL histwrite(pfileid,pvarname,pitau,pdata_mpi,nbp_mpi*dim,reshape(nindex_mpi,(/nbp_mpi*dim/))) |
---|
967 | ENDIF |
---|
968 | END SUBROUTINE body |
---|
969 | |
---|
970 | END SUBROUTINE histwrite_r2d_p |
---|
971 | |
---|
972 | !! ============================================================================================================================= |
---|
973 | !! SUBROUTINE: histwrite_r3d_p |
---|
974 | !! |
---|
975 | !>\BRIEF give the data (real 3D) to the IOIPSL system (if we don't use XIOS). |
---|
976 | !! |
---|
977 | !! DESCRIPTION: Need to be call by all process |
---|
978 | !! |
---|
979 | !! \n |
---|
980 | !_ ============================================================================================================================== |
---|
981 | SUBROUTINE histwrite_r3d_p(pfileid,pvarname,pitau,pdata,nbindex,nindex) |
---|
982 | IMPLICIT NONE |
---|
983 | !- |
---|
984 | INTEGER,INTENT(IN) :: pfileid, pitau, nbindex, nindex(nbindex) |
---|
985 | REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata |
---|
986 | CHARACTER(LEN=*),INTENT(IN) :: pvarname |
---|
987 | |
---|
988 | STOP 2 |
---|
989 | |
---|
990 | END SUBROUTINE histwrite_r3d_p |
---|
991 | |
---|
992 | !! ============================================================================================================================= |
---|
993 | !! SUBROUTINE: restput_p_nogrid_r_scal |
---|
994 | !! |
---|
995 | !>\BRIEF save real scalar (non-grid) data into the restart file |
---|
996 | !! |
---|
997 | !! DESCRIPTION: Need to be call by all process |
---|
998 | !! |
---|
999 | !! \n |
---|
1000 | !_ ============================================================================================================================== |
---|
1001 | SUBROUTINE restput_p_nogrid_r_scal (fid,vname_q,itau,var) |
---|
1002 | IMPLICIT NONE |
---|
1003 | !- |
---|
1004 | INTEGER :: fid |
---|
1005 | CHARACTER(LEN=*) :: vname_q |
---|
1006 | INTEGER :: itau |
---|
1007 | REAL :: var |
---|
1008 | !----------------------------- |
---|
1009 | REAL :: xtmp(1) |
---|
1010 | |
---|
1011 | IF (is_root_prc) THEN |
---|
1012 | xtmp(1) = var |
---|
1013 | CALL restput (fid, vname_q, 1, 1, 1, itau, xtmp) |
---|
1014 | ENDIF |
---|
1015 | |
---|
1016 | END SUBROUTINE restput_p_nogrid_r_scal |
---|
1017 | |
---|
1018 | !! ============================================================================================================================= |
---|
1019 | !! SUBROUTINE: restput_p_nogrid_i_scal |
---|
1020 | !! |
---|
1021 | !>\BRIEF save integer scalar (non-grid) data into the restart file |
---|
1022 | !! |
---|
1023 | !! DESCRIPTION: Need to be call by all process |
---|
1024 | !! |
---|
1025 | !! \n |
---|
1026 | !_ ============================================================================================================================== |
---|
1027 | SUBROUTINE restput_p_nogrid_i_scal (fid,vname_q,itau,var) |
---|
1028 | IMPLICIT NONE |
---|
1029 | !- |
---|
1030 | INTEGER :: fid |
---|
1031 | CHARACTER(LEN=*) :: vname_q |
---|
1032 | INTEGER :: itau |
---|
1033 | INTEGER :: var |
---|
1034 | !----------------------------- |
---|
1035 | REAL :: xtmp(1) |
---|
1036 | REAL :: realvar |
---|
1037 | |
---|
1038 | IF (is_root_prc) THEN |
---|
1039 | realvar = REAL(var,r_std) |
---|
1040 | xtmp(1) = realvar |
---|
1041 | CALL restput (fid, vname_q, 1, 1, 1, itau, xtmp) |
---|
1042 | ENDIF |
---|
1043 | |
---|
1044 | END SUBROUTINE restput_p_nogrid_i_scal |
---|
1045 | |
---|
1046 | !! ============================================================================================================================= |
---|
1047 | !! SUBROUTINE: restget_p_nogrid_r_scal |
---|
1048 | !! |
---|
1049 | !>\BRIEF Transform the data (real scalar) from the restart file onto the model grid |
---|
1050 | !! |
---|
1051 | !! DESCRIPTION: |
---|
1052 | !! \n |
---|
1053 | !_ ============================================================================================================================== |
---|
1054 | SUBROUTINE restget_p_nogrid_r_scal & |
---|
1055 | (fid,vname_q,itau,def_beha,def_val,var) |
---|
1056 | ! |
---|
1057 | IMPLICIT NONE |
---|
1058 | !- |
---|
1059 | INTEGER, INTENT(in) :: fid |
---|
1060 | CHARACTER(LEN=*), INTENT(in) :: vname_q |
---|
1061 | INTEGER, INTENT(in) :: itau |
---|
1062 | LOGICAL, INTENT(in) :: def_beha |
---|
1063 | REAL, INTENT(in) :: def_val |
---|
1064 | REAL, INTENT(out) :: var |
---|
1065 | !------------------------- |
---|
1066 | REAL, DIMENSION(1) :: tmp |
---|
1067 | |
---|
1068 | tmp(1) = var |
---|
1069 | IF (is_root_prc) THEN |
---|
1070 | var = val_exp |
---|
1071 | CALL restget (fid, vname_q, 1 ,1 , 1, itau, def_beha, tmp) |
---|
1072 | var = tmp(1) |
---|
1073 | IF(var == val_exp) var = def_val |
---|
1074 | ENDIF |
---|
1075 | CALL bcast(var) |
---|
1076 | |
---|
1077 | END SUBROUTINE restget_p_nogrid_r_scal |
---|
1078 | |
---|
1079 | !! ============================================================================================================================= |
---|
1080 | !! SUBROUTINE: restget_p_nogrid_i_scal |
---|
1081 | !! |
---|
1082 | !>\BRIEF Transform the data (integer scalar) from the restart file onto the model grid |
---|
1083 | !! |
---|
1084 | !! DESCRIPTION: |
---|
1085 | !! \n |
---|
1086 | !_ ============================================================================================================================== |
---|
1087 | SUBROUTINE restget_p_nogrid_i_scal & |
---|
1088 | (fid,vname_q,itau,def_beha,def_val,varint) |
---|
1089 | ! |
---|
1090 | IMPLICIT NONE |
---|
1091 | !- |
---|
1092 | INTEGER, INTENT(in) :: fid |
---|
1093 | CHARACTER(LEN=*), INTENT(in) :: vname_q |
---|
1094 | INTEGER, INTENT(in) :: itau |
---|
1095 | LOGICAL, INTENT(in) :: def_beha |
---|
1096 | REAL, INTENT(in) :: def_val |
---|
1097 | INTEGER, INTENT(out) :: varint |
---|
1098 | !------------------------- |
---|
1099 | REAL :: tmp |
---|
1100 | |
---|
1101 | CALL restget_p_nogrid_r_scal(fid, vname_q, itau, def_beha, def_val, tmp) |
---|
1102 | varint = INT(tmp) |
---|
1103 | END SUBROUTINE restget_p_nogrid_i_scal |
---|
1104 | |
---|
1105 | |
---|
1106 | END MODULE ioipsl_para |
---|