New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

lib_fortran.F90 in branches/2013/dev_r3406_CNRS_LIM3/NEMOGCM/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/2013/dev_r3406_CNRS_LIM3/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90 @ 3981

Last change on this file since 3981 was 3981, checked in by clem, 11 years ago
bug correction
Property svn:keywords set to `Id`
File size: 35.8 KB

Line
1	MODULE lib_fortran
2	!!======================================================================
3	!! * MODULE lib_fortran *
4	!! Fortran utilities: includes some low levels fortran functionality
5	!!======================================================================
6	!! History : 3.2 ! 2010-05 (M. Dunphy, R. Benshila) Original code
7	!! 3.4 ! 2013-06 (C. Rousset) add glob_min, glob_max
8	!! + 3d dim. of input is fexible (jpk, jpl...)
9	!!----------------------------------------------------------------------
10
11	!!----------------------------------------------------------------------
12	!! glob_sum : generic interface for global masked summation over
13	!! the interior domain for 1 or 2 2D or 3D arrays
14	!! it works only for T points
15	!! SIGN : generic interface for SIGN to overwrite f95 behaviour
16	!! of intrinsinc sign function
17	!!----------------------------------------------------------------------
18	USE par_oce ! Ocean parameter
19	USE lib_mpp ! distributed memory computing
20	USE dom_oce ! ocean domain
21	USE in_out_manager ! I/O manager
22
23	IMPLICIT NONE
24	PRIVATE
25
26	PUBLIC glob_sum
27	PUBLIC glob_min, glob_max
28	#if defined key_nosignedzero
29	PUBLIC SIGN
30	#endif
31
32	INTERFACE glob_sum
33	MODULE PROCEDURE glob_sum_2d, glob_sum_3d,glob_sum_2d_a, glob_sum_3d_a
34	END INTERFACE
35	INTERFACE glob_min
36	MODULE PROCEDURE glob_min_2d, glob_min_3d,glob_min_2d_a, glob_min_3d_a
37	END INTERFACE
38	INTERFACE glob_max
39	MODULE PROCEDURE glob_max_2d, glob_max_3d,glob_max_2d_a, glob_max_3d_a
40	END INTERFACE
41
42	#if defined key_nosignedzero
43	INTERFACE SIGN
44	MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D, &
45	& SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A, &
46	& SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B
47	END INTERFACE
48	#endif
49
50	!!----------------------------------------------------------------------
51	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
52	!! $Id$
53	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
54	!!----------------------------------------------------------------------
55	CONTAINS
56
57	#if ! defined key_mpp_rep
58
59	! --- SUM ---
60	FUNCTION glob_sum_2d( ptab )
61	!!-----------------------------------------------------------------------
62	!! * FUNCTION glob_sum_2D *
63	!!
64	!! ** Purpose : perform a masked sum on the inner global domain of a 2D array
65	!!-----------------------------------------------------------------------
66	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array
67	REAL(wp) :: glob_sum_2d ! global masked sum
68	!!-----------------------------------------------------------------------
69	!
70	glob_sum_2d = SUM( ptab(:,:)*tmask_i(:,:) )
71	IF( lk_mpp ) CALL mpp_sum( glob_sum_2d )
72	!
73	END FUNCTION glob_sum_2d
74
75	FUNCTION glob_sum_3d( ptab )
76	!!-----------------------------------------------------------------------
77	!! * FUNCTION glob_sum_3D *
78	!!
79	!! ** Purpose : perform a masked sum on the inner global domain of a 3D array
80	!!-----------------------------------------------------------------------
81	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array
82	REAL(wp) :: glob_sum_3d ! global masked sum
83	!!
84	INTEGER :: jk
85	INTEGER :: zjpk ! local variable: size of the 3d dimension of ptab
86	!!-----------------------------------------------------------------------
87	!
88	zjpk = SIZE(ptab,3)
89	!
90	glob_sum_3d = 0.e0
91	DO jk = 1, zjpk
92	glob_sum_3d = glob_sum_3d + SUM( ptab(:,:,jk)*tmask_i(:,:) )
93	END DO
94	IF( lk_mpp ) CALL mpp_sum( glob_sum_3d )
95	!
96	END FUNCTION glob_sum_3d
97
98
99	FUNCTION glob_sum_2d_a( ptab1, ptab2 )
100	!!-----------------------------------------------------------------------
101	!! * FUNCTION glob_sum_2D _a *
102	!!
103	!! ** Purpose : perform a masked sum on the inner global domain of two 2D array
104	!!-----------------------------------------------------------------------
105	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array
106	REAL(wp) , DIMENSION(2) :: glob_sum_2d_a ! global masked sum
107	!!-----------------------------------------------------------------------
108	!
109	glob_sum_2d_a(1) = SUM( ptab1(:,:)*tmask_i(:,:) )
110	glob_sum_2d_a(2) = SUM( ptab2(:,:)*tmask_i(:,:) )
111	IF( lk_mpp ) CALL mpp_sum( glob_sum_2d_a, 2 )
112	!
113	END FUNCTION glob_sum_2d_a
114
115
116	FUNCTION glob_sum_3d_a( ptab1, ptab2 )
117	!!-----------------------------------------------------------------------
118	!! * FUNCTION glob_sum_3D_a *
119	!!
120	!! ** Purpose : perform a masked sum on the inner global domain of two 3D array
121	!!-----------------------------------------------------------------------
122	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array
123	REAL(wp) , DIMENSION(2) :: glob_sum_3d_a ! global masked sum
124	!!
125	INTEGER :: jk
126	INTEGER :: zjpk ! local variable: size of the 3d dimension of ptab
127	!!-----------------------------------------------------------------------
128	!
129	zjpk = SIZE(ptab1,3)
130	!
131	glob_sum_3d_a(:) = 0.e0
132	DO jk = 1, zjpk
133	glob_sum_3d_a(1) = glob_sum_3d_a(1) + SUM( ptab1(:,:,jk)*tmask_i(:,:) )
134	glob_sum_3d_a(2) = glob_sum_3d_a(2) + SUM( ptab2(:,:,jk)*tmask_i(:,:) )
135	END DO
136	IF( lk_mpp ) CALL mpp_sum( glob_sum_3d_a, 2 )
137	!
138	END FUNCTION glob_sum_3d_a
139
140
141	! --- MIN ---
142	FUNCTION glob_min_2d( ptab )
143	!!-----------------------------------------------------------------------
144	!! * FUNCTION glob_min_2D *
145	!!
146	!! ** Purpose : perform a masked min on the inner global domain of a 2D array
147	!!-----------------------------------------------------------------------
148	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array
149	REAL(wp) :: glob_min_2d ! global masked min
150	!!-----------------------------------------------------------------------
151	!
152	glob_min_2d = MINVAL( ptab(:,:)*tmask_i(:,:) )
153	IF( lk_mpp ) CALL mpp_min( glob_min_2d )
154	!
155	END FUNCTION glob_min_2d
156
157	FUNCTION glob_min_3d( ptab )
158	!!-----------------------------------------------------------------------
159	!! * FUNCTION glob_min_3D *
160	!!
161	!! ** Purpose : perform a masked min on the inner global domain of a 3D array
162	!!-----------------------------------------------------------------------
163	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array
164	REAL(wp) :: glob_min_3d ! global masked min
165	!!
166	INTEGER :: jk
167	INTEGER :: zjpk ! local variable: size of the 3d dimension of ptab
168	!!-----------------------------------------------------------------------
169	!
170	zjpk = SIZE(ptab,3)
171	!
172	glob_min_3d = 0.e0
173	DO jk = 1, zjpk
174	glob_min_3d = glob_min_3d + MINVAL( ptab(:,:,jk)*tmask_i(:,:) )
175	END DO
176	IF( lk_mpp ) CALL mpp_min( glob_min_3d )
177	!
178	END FUNCTION glob_min_3d
179
180
181	FUNCTION glob_min_2d_a( ptab1, ptab2 )
182	!!-----------------------------------------------------------------------
183	!! * FUNCTION glob_min_2D _a *
184	!!
185	!! ** Purpose : perform a masked min on the inner global domain of two 2D array
186	!!-----------------------------------------------------------------------
187	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array
188	REAL(wp) , DIMENSION(2) :: glob_min_2d_a ! global masked min
189	!!-----------------------------------------------------------------------
190	!
191	glob_min_2d_a(1) = MINVAL( ptab1(:,:)*tmask_i(:,:) )
192	glob_min_2d_a(2) = MINVAL( ptab2(:,:)*tmask_i(:,:) )
193	IF( lk_mpp ) CALL mpp_min( glob_min_2d_a, 2 )
194	!
195	END FUNCTION glob_min_2d_a
196
197
198	FUNCTION glob_min_3d_a( ptab1, ptab2 )
199	!!-----------------------------------------------------------------------
200	!! * FUNCTION glob_min_3D_a *
201	!!
202	!! ** Purpose : perform a masked min on the inner global domain of two 3D array
203	!!-----------------------------------------------------------------------
204	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array
205	REAL(wp) , DIMENSION(2) :: glob_min_3d_a ! global masked min
206	!!
207	INTEGER :: jk
208	INTEGER :: zjpk ! local variable: size of the 3d dimension of ptab
209	!!-----------------------------------------------------------------------
210	!
211	zjpk = SIZE(ptab1,3)
212	!
213	glob_min_3d_a(:) = 0.e0
214	DO jk = 1, zjpk
215	glob_min_3d_a(1) = glob_min_3d_a(1) + MINVAL( ptab1(:,:,jk)*tmask_i(:,:) )
216	glob_min_3d_a(2) = glob_min_3d_a(2) + MINVAL( ptab2(:,:,jk)*tmask_i(:,:) )
217	END DO
218	IF( lk_mpp ) CALL mpp_min( glob_min_3d_a, 2 )
219	!
220	END FUNCTION glob_min_3d_a
221
222	! --- MAX ---
223	FUNCTION glob_max_2d( ptab )
224	!!-----------------------------------------------------------------------
225	!! * FUNCTION glob_max_2D *
226	!!
227	!! ** Purpose : perform a masked max on the inner global domain of a 2D array
228	!!-----------------------------------------------------------------------
229	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array
230	REAL(wp) :: glob_max_2d ! global masked max
231	!!-----------------------------------------------------------------------
232	!
233	glob_max_2d = MAXVAL( ptab(:,:)*tmask_i(:,:) )
234	IF( lk_mpp ) CALL mpp_max( glob_max_2d )
235	!
236	END FUNCTION glob_max_2d
237
238	FUNCTION glob_max_3d( ptab )
239	!!-----------------------------------------------------------------------
240	!! * FUNCTION glob_max_3D *
241	!!
242	!! ** Purpose : perform a masked max on the inner global domain of a 3D array
243	!!-----------------------------------------------------------------------
244	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array
245	REAL(wp) :: glob_max_3d ! global masked max
246	!!
247	INTEGER :: jk
248	INTEGER :: zjpk ! local variable: size of the 3d dimension of ptab
249	!!-----------------------------------------------------------------------
250	!
251	zjpk = SIZE(ptab,3)
252	!
253	glob_max_3d = 0.e0
254	DO jk = 1, zjpk
255	glob_max_3d = glob_max_3d + MAXVAL( ptab(:,:,jk)*tmask_i(:,:) )
256	END DO
257	IF( lk_mpp ) CALL mpp_max( glob_max_3d )
258	!
259	END FUNCTION glob_max_3d
260
261
262	FUNCTION glob_max_2d_a( ptab1, ptab2 )
263	!!-----------------------------------------------------------------------
264	!! * FUNCTION glob_max_2D _a *
265	!!
266	!! ** Purpose : perform a masked max on the inner global domain of two 2D array
267	!!-----------------------------------------------------------------------
268	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array
269	REAL(wp) , DIMENSION(2) :: glob_max_2d_a ! global masked max
270	!!-----------------------------------------------------------------------
271	!
272	glob_max_2d_a(1) = MAXVAL( ptab1(:,:)*tmask_i(:,:) )
273	glob_max_2d_a(2) = MAXVAL( ptab2(:,:)*tmask_i(:,:) )
274	IF( lk_mpp ) CALL mpp_max( glob_max_2d_a, 2 )
275	!
276	END FUNCTION glob_max_2d_a
277
278
279	FUNCTION glob_max_3d_a( ptab1, ptab2 )
280	!!-----------------------------------------------------------------------
281	!! * FUNCTION glob_max_3D_a *
282	!!
283	!! ** Purpose : perform a masked max on the inner global domain of two 3D array
284	!!-----------------------------------------------------------------------
285	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array
286	REAL(wp) , DIMENSION(2) :: glob_max_3d_a ! global masked max
287	!!
288	INTEGER :: jk
289	INTEGER :: zjpk ! local variable: size of the 3d dimension of ptab
290	!!-----------------------------------------------------------------------
291	!
292	zjpk = SIZE(ptab1,3)
293	!
294	glob_max_3d_a(:) = 0.e0
295	DO jk = 1, zjpk
296	glob_max_3d_a(1) = glob_max_3d_a(1) + MAXVAL( ptab1(:,:,jk)*tmask_i(:,:) )
297	glob_max_3d_a(2) = glob_max_3d_a(2) + MAXVAL( ptab2(:,:,jk)*tmask_i(:,:) )
298	END DO
299	IF( lk_mpp ) CALL mpp_max( glob_max_3d_a, 2 )
300	!
301	END FUNCTION glob_max_3d_a
302
303
304	#else
305	!!----------------------------------------------------------------------
306	!! 'key_mpp_rep' MPP reproducibility
307	!!----------------------------------------------------------------------
308
309	! --- SUM ---
310	FUNCTION glob_sum_2d( ptab )
311	!!----------------------------------------------------------------------
312	!! * FUNCTION glob_sum_2d *
313	!!
314	!! ** Purpose : perform a sum in calling DDPDD routine
315	!!----------------------------------------------------------------------
316	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab
317	REAL(wp) :: glob_sum_2d ! global masked sum
318	!!
319	COMPLEX(wp):: ctmp
320	REAL(wp) :: ztmp
321	INTEGER :: ji, jj ! dummy loop indices
322	!!-----------------------------------------------------------------------
323	!
324	ztmp = 0.e0
325	ctmp = CMPLX( 0.e0, 0.e0, wp )
326	DO jj = 1, jpj
327	DO ji = 1, jpi
328	ztmp = ptab(ji,jj) * tmask_i(ji,jj)
329	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
330	END DO
331	END DO
332	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
333	glob_sum_2d = REAL(ctmp,wp)
334	!
335	END FUNCTION glob_sum_2d
336
337
338	FUNCTION glob_sum_3d( ptab )
339	!!----------------------------------------------------------------------
340	!! * FUNCTION glob_sum_3d *
341	!!
342	!! ** Purpose : perform a sum on a 3D array in calling DDPDD routine
343	!!----------------------------------------------------------------------
344	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab
345	REAL(wp) :: glob_sum_3d ! global masked sum
346	!!
347	COMPLEX(wp):: ctmp
348	REAL(wp) :: ztmp
349	INTEGER :: ji, jj, jk ! dummy loop indices
350	INTEGER :: zjpk ! local variables: size of ptab
351	!!-----------------------------------------------------------------------
352	!
353	zjpk = SIZE(ptab,3)
354	!
355	ztmp = 0.e0
356	ctmp = CMPLX( 0.e0, 0.e0, wp )
357	DO jk = 1, zjpk
358	DO jj = 1, jpj
359	DO ji = 1, jpi
360	ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj)
361	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
362	END DO
363	END DO
364	END DO
365	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
366	glob_sum_3d = REAL(ctmp,wp)
367	!
368	END FUNCTION glob_sum_3d
369
370
371	FUNCTION glob_sum_2d_a( ptab1, ptab2 )
372	!!----------------------------------------------------------------------
373	!! * FUNCTION glob_sum_2d_a *
374	!!
375	!! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine
376	!!----------------------------------------------------------------------
377	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2
378	REAL(wp) :: glob_sum_2d_a ! global masked sum
379	!!
380	COMPLEX(wp):: ctmp
381	REAL(wp) :: ztmp
382	INTEGER :: ji, jj ! dummy loop indices
383	!!-----------------------------------------------------------------------
384	!
385	ztmp = 0.e0
386	ctmp = CMPLX( 0.e0, 0.e0, wp )
387	DO jj = 1, jpj
388	DO ji = 1, jpi
389	ztmp = ptab1(ji,jj) * tmask_i(ji,jj)
390	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
391	ztmp = ptab2(ji,jj) * tmask_i(ji,jj)
392	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
393	END DO
394	END DO
395	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
396	glob_sum_2d_a = REAL(ctmp,wp)
397	!
398	END FUNCTION glob_sum_2d_a
399
400
401	FUNCTION glob_sum_3d_a( ptab1, ptab2 )
402	!!----------------------------------------------------------------------
403	!! * FUNCTION glob_sum_3d_a *
404	!!
405	!! ** Purpose : perform a sum on two 3D array in calling DDPDD routine
406	!!----------------------------------------------------------------------
407	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2
408	REAL(wp) :: glob_sum_3d_a ! global masked sum
409	!!
410	COMPLEX(wp):: ctmp
411	REAL(wp) :: ztmp
412	INTEGER :: ji, jj, jk ! dummy loop indices
413	INTEGER :: zjpk ! local variables: size of ptab
414	!!-----------------------------------------------------------------------
415	!
416	zjpk = SIZE(ptab1,3)
417	!
418	ztmp = 0.e0
419	ctmp = CMPLX( 0.e0, 0.e0, wp )
420	DO jk = 1, zjpk
421	DO jj = 1, jpj
422	DO ji = 1, jpi
423	ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj)
424	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
425	ztmp = ptab2(ji,jj,jk) * tmask_i(ji,jj)
426	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
427	END DO
428	END DO
429	END DO
430	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
431	glob_sum_3d_a = REAL(ctmp,wp)
432	!
433	END FUNCTION glob_sum_3d_a
434
435
436	! --- MIN ---
437	FUNCTION glob_min_2d( ptab )
438	!!----------------------------------------------------------------------
439	!! * FUNCTION glob_min_2d *
440	!!
441	!! ** Purpose : perform a min in calling DDPDD routine
442	!!----------------------------------------------------------------------
443	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab
444	REAL(wp) :: glob_min_2d ! global masked min
445	!!
446	COMPLEX(wp):: ctmp
447	REAL(wp) :: ztmp
448	INTEGER :: ji, jj ! dummy loop indices
449	!!-----------------------------------------------------------------------
450	!
451	ztmp = 0.e0
452	ctmp = CMPLX( 0.e0, 0.e0, wp )
453	DO jj = 1, jpj
454	DO ji = 1, jpi
455	ztmp = ptab(ji,jj) * tmask_i(ji,jj)
456	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
457	END DO
458	END DO
459	IF( lk_mpp ) CALL mpp_min( ctmp ) ! min over the global domain
460	glob_min_2d = REAL(ctmp,wp)
461	!
462	END FUNCTION glob_min_2d
463
464
465	FUNCTION glob_min_3d( ptab )
466	!!----------------------------------------------------------------------
467	!! * FUNCTION glob_min_3d *
468	!!
469	!! ** Purpose : perform a min on a 3D array in calling DDPDD routine
470	!!----------------------------------------------------------------------
471	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab
472	REAL(wp) :: glob_min_3d ! global masked min
473	!!
474	COMPLEX(wp):: ctmp
475	REAL(wp) :: ztmp
476	INTEGER :: ji, jj, jk ! dummy loop indices
477	INTEGER :: zjpk ! local variables: size of ptab
478	!!-----------------------------------------------------------------------
479	!
480	zjpk = SIZE(ptab,3)
481	!
482	ztmp = 0.e0
483	ctmp = CMPLX( 0.e0, 0.e0, wp )
484	DO jk = 1, zjpk
485	DO jj = 1, jpj
486	DO ji = 1, jpi
487	ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj)
488	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
489	END DO
490	END DO
491	END DO
492	IF( lk_mpp ) CALL mpp_min( ctmp ) ! min over the global domain
493	glob_min_3d = REAL(ctmp,wp)
494	!
495	END FUNCTION glob_min_3d
496
497
498	FUNCTION glob_min_2d_a( ptab1, ptab2 )
499	!!----------------------------------------------------------------------
500	!! * FUNCTION glob_min_2d_a *
501	!!
502	!! ** Purpose : perform a min on two 2D arrays in calling DDPDD routine
503	!!----------------------------------------------------------------------
504	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2
505	REAL(wp) :: glob_min_2d_a ! global masked min
506	!!
507	COMPLEX(wp):: ctmp
508	REAL(wp) :: ztmp
509	INTEGER :: ji, jj ! dummy loop indices
510	!!-----------------------------------------------------------------------
511	!
512	!
513	ztmp = 0.e0
514	ctmp = CMPLX( 0.e0, 0.e0, wp )
515	DO jj = 1, jpj
516	DO ji = 1, jpi
517	ztmp = ptab1(ji,jj) * tmask_i(ji,jj)
518	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
519	ztmp = ptab2(ji,jj) * tmask_i(ji,jj)
520	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
521	END DO
522	END DO
523	IF( lk_mpp ) CALL mpp_min( ctmp ) ! min over the global domain
524	glob_min_2d_a = REAL(ctmp,wp)
525	!
526	END FUNCTION glob_min_2d_a
527
528
529	FUNCTION glob_min_3d_a( ptab1, ptab2 )
530	!!----------------------------------------------------------------------
531	!! * FUNCTION glob_min_3d_a *
532	!!
533	!! ** Purpose : perform a min on two 3D array in calling DDPDD routine
534	!!----------------------------------------------------------------------
535	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2
536	REAL(wp) :: glob_min_3d_a ! global masked min
537	!!
538	COMPLEX(wp):: ctmp
539	REAL(wp) :: ztmp
540	INTEGER :: ji, jj, jk ! dummy loop indices
541	INTEGER :: zjpk ! local variables: size of ptab
542	!!-----------------------------------------------------------------------
543	!
544	zjpk = SIZE(ptab1,3)
545	!
546	ztmp = 0.e0
547	ctmp = CMPLX( 0.e0, 0.e0, wp )
548	DO jk = 1, zjpk
549	DO jj = 1, jpj
550	DO ji = 1, jpi
551	ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj)
552	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
553	ztmp = ptab2(ji,jj,jk) * tmask_i(ji,jj)
554	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
555	END DO
556	END DO
557	END DO
558	IF( lk_mpp ) CALL mpp_min( ctmp ) ! min over the global domain
559	glob_min_3d_a = REAL(ctmp,wp)
560	!
561	END FUNCTION glob_min_3d_a
562
563
564	! --- MAX ---
565	FUNCTION glob_max_2d( ptab )
566	!!----------------------------------------------------------------------
567	!! * FUNCTION glob_max_2d *
568	!!
569	!! ** Purpose : perform a max in calling DDPDD routine
570	!!----------------------------------------------------------------------
571	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab
572	REAL(wp) :: glob_max_2d ! global masked max
573	!!
574	COMPLEX(wp):: ctmp
575	REAL(wp) :: ztmp
576	INTEGER :: ji, jj ! dummy loop indices
577	!!-----------------------------------------------------------------------
578	!
579	ztmp = 0.e0
580	ctmp = CMPLX( 0.e0, 0.e0, wp )
581	DO jj = 1, jpj
582	DO ji = 1, jpi
583	ztmp = ptab(ji,jj) * tmask_i(ji,jj)
584	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
585	END DO
586	END DO
587	IF( lk_mpp ) CALL mpp_max( ctmp ) ! max over the global domain
588	glob_max_2d = REAL(ctmp,wp)
589	!
590	END FUNCTION glob_max_2d
591
592
593	FUNCTION glob_max_3d( ptab )
594	!!----------------------------------------------------------------------
595	!! * FUNCTION glob_max_3d *
596	!!
597	!! ** Purpose : perform a max on a 3D array in calling DDPDD routine
598	!!----------------------------------------------------------------------
599	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab
600	REAL(wp) :: glob_max_3d ! global masked max
601	!!
602	COMPLEX(wp):: ctmp
603	REAL(wp) :: ztmp
604	INTEGER :: ji, jj, jk ! dummy loop indices
605	INTEGER :: zjpk ! local variables: size of ptab
606	!!-----------------------------------------------------------------------
607	!
608	zjpk = SIZE(ptab,3)
609	!
610	ztmp = 0.e0
611	ctmp = CMPLX( 0.e0, 0.e0, wp )
612	DO jk = 1, zjpk
613	DO jj = 1, jpj
614	DO ji = 1, jpi
615	ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj)
616	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
617	END DO
618	END DO
619	END DO
620	IF( lk_mpp ) CALL mpp_max( ctmp ) ! max over the global domain
621	glob_max_3d = REAL(ctmp,wp)
622	!
623	END FUNCTION glob_max_3d
624
625
626	FUNCTION glob_max_2d_a( ptab1, ptab2 )
627	!!----------------------------------------------------------------------
628	!! * FUNCTION glob_max_2d_a *
629	!!
630	!! ** Purpose : perform a max on two 2D arrays in calling DDPDD routine
631	!!----------------------------------------------------------------------
632	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2
633	REAL(wp) :: glob_max_2d_a ! global masked max
634	!!
635	COMPLEX(wp):: ctmp
636	REAL(wp) :: ztmp
637	INTEGER :: ji, jj ! dummy loop indices
638	!!-----------------------------------------------------------------------
639	!
640	!
641	ztmp = 0.e0
642	ctmp = CMPLX( 0.e0, 0.e0, wp )
643	DO jj = 1, jpj
644	DO ji = 1, jpi
645	ztmp = ptab1(ji,jj) * tmask_i(ji,jj)
646	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
647	ztmp = ptab2(ji,jj) * tmask_i(ji,jj)
648	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
649	END DO
650	END DO
651	IF( lk_mpp ) CALL mpp_max( ctmp ) ! max over the global domain
652	glob_max_2d_a = REAL(ctmp,wp)
653	!
654	END FUNCTION glob_max_2d_a
655
656
657	FUNCTION glob_max_3d_a( ptab1, ptab2 )
658	!!----------------------------------------------------------------------
659	!! * FUNCTION glob_max_3d_a *
660	!!
661	!! ** Purpose : perform a max on two 3D array in calling DDPDD routine
662	!!----------------------------------------------------------------------
663	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2
664	REAL(wp) :: glob_max_3d_a ! global masked max
665	!!
666	COMPLEX(wp):: ctmp
667	REAL(wp) :: ztmp
668	INTEGER :: ji, jj, jk ! dummy loop indices
669	INTEGER :: zjpk ! local variables: size of ptab
670	!!-----------------------------------------------------------------------
671	!
672	zjpk = SIZE(ptab1,3)
673	!
674	ztmp = 0.e0
675	ctmp = CMPLX( 0.e0, 0.e0, wp )
676	DO jk = 1, zjpk
677	DO jj = 1, jpj
678	DO ji = 1, jpi
679	ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj)
680	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
681	ztmp = ptab2(ji,jj,jk) * tmask_i(ji,jj)
682	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
683	END DO
684	END DO
685	END DO
686	IF( lk_mpp ) CALL mpp_max( ctmp ) ! max over the global domain
687	glob_max_3d_a = REAL(ctmp,wp)
688	!
689	END FUNCTION glob_max_3d_a
690
691
692	SUBROUTINE DDPDD( ydda, yddb )
693	!!----------------------------------------------------------------------
694	!! * ROUTINE DDPDD *
695	!!
696	!! ** Purpose : Add a scalar element to a sum
697	!!
698	!!
699	!! ** Method : The code uses the compensated summation with doublet
700	!! (sum,error) emulated useing complex numbers. ydda is the
701	!! scalar to add to the summ yddb
702	!!
703	!! ** Action : This does only work for MPI.
704	!!
705	!! References : Using Acurate Arithmetics to Improve Numerical
706	!! Reproducibility and Sability in Parallel Applications
707	!! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
708	!!----------------------------------------------------------------------
709	COMPLEX(wp), INTENT(in ) :: ydda
710	COMPLEX(wp), INTENT(inout) :: yddb
711	!
712	REAL(wp) :: zerr, zt1, zt2 ! local work variables
713	!!-----------------------------------------------------------------------
714	!
715	! Compute ydda + yddb using Knuth's trick.
716	zt1 = REAL(ydda) + REAL(yddb)
717	zerr = zt1 - REAL(ydda)
718	zt2 = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) ) &
719	& + AIMAG(ydda) + AIMAG(yddb)
720	!
721	! The result is t1 + t2, after normalization.
722	yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
723	!
724	END SUBROUTINE DDPDD
725	#endif
726
727	#if defined key_nosignedzero
728	!!----------------------------------------------------------------------
729	!! 'key_nosignedzero' F90 SIGN
730	!!----------------------------------------------------------------------
731
732	FUNCTION SIGN_SCALAR( pa, pb )
733	!!-----------------------------------------------------------------------
734	!! * FUNCTION SIGN_SCALAR *
735	!!
736	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
737	!!-----------------------------------------------------------------------
738	REAL(wp) :: pa,pb ! input
739	REAL(wp) :: SIGN_SCALAR ! result
740	!!-----------------------------------------------------------------------
741	IF ( pb >= 0.e0) THEN ; SIGN_SCALAR = ABS(pa)
742	ELSE ; SIGN_SCALAR =-ABS(pa)
743	ENDIF
744	END FUNCTION SIGN_SCALAR
745
746
747	FUNCTION SIGN_ARRAY_1D( pa, pb )
748	!!-----------------------------------------------------------------------
749	!! * FUNCTION SIGN_ARRAY_1D *
750	!!
751	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
752	!!-----------------------------------------------------------------------
753	REAL(wp) :: pa,pb(:) ! input
754	REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1)) ! result
755	!!-----------------------------------------------------------------------
756	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D = ABS(pa)
757	ELSEWHERE ; SIGN_ARRAY_1D =-ABS(pa)
758	END WHERE
759	END FUNCTION SIGN_ARRAY_1D
760
761
762	FUNCTION SIGN_ARRAY_2D(pa,pb)
763	!!-----------------------------------------------------------------------
764	!! * FUNCTION SIGN_ARRAY_2D *
765	!!
766	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
767	!!-----------------------------------------------------------------------
768	REAL(wp) :: pa,pb(:,:) ! input
769	REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2)) ! result
770	!!-----------------------------------------------------------------------
771	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D = ABS(pa)
772	ELSEWHERE ; SIGN_ARRAY_2D =-ABS(pa)
773	END WHERE
774	END FUNCTION SIGN_ARRAY_2D
775
776	FUNCTION SIGN_ARRAY_3D(pa,pb)
777	!!-----------------------------------------------------------------------
778	!! * FUNCTION SIGN_ARRAY_3D *
779	!!
780	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
781	!!-----------------------------------------------------------------------
782	REAL(wp) :: pa,pb(:,:,:) ! input
783	REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
784	!!-----------------------------------------------------------------------
785	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D = ABS(pa)
786	ELSEWHERE ; SIGN_ARRAY_3D =-ABS(pa)
787	END WHERE
788	END FUNCTION SIGN_ARRAY_3D
789
790
791	FUNCTION SIGN_ARRAY_1D_A(pa,pb)
792	!!-----------------------------------------------------------------------
793	!! * FUNCTION SIGN_ARRAY_1D_A *
794	!!
795	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
796	!!-----------------------------------------------------------------------
797	REAL(wp) :: pa(:),pb(:) ! input
798	REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1)) ! result
799	!!-----------------------------------------------------------------------
800	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D_A = ABS(pa)
801	ELSEWHERE ; SIGN_ARRAY_1D_A =-ABS(pa)
802	END WHERE
803	END FUNCTION SIGN_ARRAY_1D_A
804
805
806	FUNCTION SIGN_ARRAY_2D_A(pa,pb)
807	!!-----------------------------------------------------------------------
808	!! * FUNCTION SIGN_ARRAY_2D_A *
809	!!
810	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
811	!!-----------------------------------------------------------------------
812	REAL(wp) :: pa(:,:),pb(:,:) ! input
813	REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2)) ! result
814	!!-----------------------------------------------------------------------
815	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D_A = ABS(pa)
816	ELSEWHERE ; SIGN_ARRAY_2D_A =-ABS(pa)
817	END WHERE
818	END FUNCTION SIGN_ARRAY_2D_A
819
820
821	FUNCTION SIGN_ARRAY_3D_A(pa,pb)
822	!!-----------------------------------------------------------------------
823	!! * FUNCTION SIGN_ARRAY_3D_A *
824	!!
825	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
826	!!-----------------------------------------------------------------------
827	REAL(wp) :: pa(:,:,:),pb(:,:,:) ! input
828	REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
829	!!-----------------------------------------------------------------------
830	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D_A = ABS(pa)
831	ELSEWHERE ; SIGN_ARRAY_3D_A =-ABS(pa)
832	END WHERE
833	END FUNCTION SIGN_ARRAY_3D_A
834
835
836	FUNCTION SIGN_ARRAY_1D_B(pa,pb)
837	!!-----------------------------------------------------------------------
838	!! * FUNCTION SIGN_ARRAY_1D_B *
839	!!
840	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
841	!!-----------------------------------------------------------------------
842	REAL(wp) :: pa(:),pb ! input
843	REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1)) ! result
844	!!-----------------------------------------------------------------------
845	IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_1D_B = ABS(pa)
846	ELSE ; SIGN_ARRAY_1D_B =-ABS(pa)
847	ENDIF
848	END FUNCTION SIGN_ARRAY_1D_B
849
850
851	FUNCTION SIGN_ARRAY_2D_B(pa,pb)
852	!!-----------------------------------------------------------------------
853	!! * FUNCTION SIGN_ARRAY_2D_B *
854	!!
855	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
856	!!-----------------------------------------------------------------------
857	REAL(wp) :: pa(:,:),pb ! input
858	REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2)) ! result
859	!!-----------------------------------------------------------------------
860	IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_2D_B = ABS(pa)
861	ELSE ; SIGN_ARRAY_2D_B =-ABS(pa)
862	ENDIF
863	END FUNCTION SIGN_ARRAY_2D_B
864
865
866	FUNCTION SIGN_ARRAY_3D_B(pa,pb)
867	!!-----------------------------------------------------------------------
868	!! * FUNCTION SIGN_ARRAY_3D_B *
869	!!
870	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
871	!!-----------------------------------------------------------------------
872	REAL(wp) :: pa(:,:,:),pb ! input
873	REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3)) ! result
874	!!-----------------------------------------------------------------------
875	IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_3D_B = ABS(pa)
876	ELSE ; SIGN_ARRAY_3D_B =-ABS(pa)
877	ENDIF
878	END FUNCTION SIGN_ARRAY_3D_B
879	#endif
880
881	!!======================================================================
882	END MODULE lib_fortran

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

Download in other formats: