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_r4028_CNRS_LIM3/NEMOGCM/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/2013/dev_r4028_CNRS_LIM3/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90 @ 4037

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

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

Download in other formats: