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 @ 3963

Last change on this file since 3963 was 3963, checked in by clem, 11 years ago
bugs correction + creation of glob_max and glob_min in lib_fortran.F90, see ticket:#1116
Property svn:keywords set to `Id`
File size: 36.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	INTEGER :: zjpi, zjpj ! local variables: size of ptab
323	!!-----------------------------------------------------------------------
324	zjpi = SIZE(ptab,1)
325	zjpj = SIZE(ptab,2)
326	!
327	ztmp = 0.e0
328	ctmp = CMPLX( 0.e0, 0.e0, wp )
329	DO jj = 1, zjpj
330	DO ji =1, zjpi
331	ztmp = ptab(ji,jj) * tmask_i(ji,jj)
332	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
333	END DO
334	END DO
335	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
336	glob_sum_2d = REAL(ctmp,wp)
337	!
338	END FUNCTION glob_sum_2d
339
340
341	FUNCTION glob_sum_3d( ptab )
342	!!----------------------------------------------------------------------
343	!! * FUNCTION glob_sum_3d *
344	!!
345	!! ** Purpose : perform a sum on a 3D array in calling DDPDD routine
346	!!----------------------------------------------------------------------
347	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab
348	REAL(wp) :: glob_sum_3d ! global masked sum
349	!!
350	COMPLEX(wp):: ctmp
351	REAL(wp) :: ztmp
352	INTEGER :: ji, jj, jk ! dummy loop indices
353	INTEGER :: zjpi, zjpj, zjpk ! local variables: size of ptab
354	!!-----------------------------------------------------------------------
355	!
356	zjpi = SIZE(ptab,1)
357	zjpj = SIZE(ptab,2)
358	zjpk = SIZE(ptab,3)
359	!
360	ztmp = 0.e0
361	ctmp = CMPLX( 0.e0, 0.e0, wp )
362	DO jk = 1, zjpk
363	DO jj = 1, zjpj
364	DO ji =1, zjpi
365	ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj)
366	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
367	END DO
368	END DO
369	END DO
370	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
371	glob_sum_3d = REAL(ctmp,wp)
372	!
373	END FUNCTION glob_sum_3d
374
375
376	FUNCTION glob_sum_2d_a( ptab1, ptab2 )
377	!!----------------------------------------------------------------------
378	!! * FUNCTION glob_sum_2d_a *
379	!!
380	!! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine
381	!!----------------------------------------------------------------------
382	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2
383	REAL(wp) :: glob_sum_2d_a ! global masked sum
384	!!
385	COMPLEX(wp):: ctmp
386	REAL(wp) :: ztmp
387	INTEGER :: ji, jj ! dummy loop indices
388	INTEGER :: zjpi, zjpj ! local variables: size of ptab
389	!!-----------------------------------------------------------------------
390	!
391	zjpi = SIZE(ptab1,1)
392	zjpj = SIZE(ptab1,2)
393	!
394	ztmp = 0.e0
395	ctmp = CMPLX( 0.e0, 0.e0, wp )
396	DO jj = 1, zjpj
397	DO ji =1, zjpi
398	ztmp = ptab1(ji,jj) * tmask_i(ji,jj)
399	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
400	ztmp = ptab2(ji,jj) * tmask_i(ji,jj)
401	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
402	END DO
403	END DO
404	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
405	glob_sum_2d_a = REAL(ctmp,wp)
406	!
407	END FUNCTION glob_sum_2d_a
408
409
410	FUNCTION glob_sum_3d_a( ptab1, ptab2 )
411	!!----------------------------------------------------------------------
412	!! * FUNCTION glob_sum_3d_a *
413	!!
414	!! ** Purpose : perform a sum on two 3D array in calling DDPDD routine
415	!!----------------------------------------------------------------------
416	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2
417	REAL(wp) :: glob_sum_3d_a ! global masked sum
418	!!
419	COMPLEX(wp):: ctmp
420	REAL(wp) :: ztmp
421	INTEGER :: ji, jj, jk ! dummy loop indices
422	INTEGER :: zjpi, zjpj, zjpk ! local variables: size of ptab
423	!!-----------------------------------------------------------------------
424	!
425	zjpi = SIZE(ptab1,1)
426	zjpj = SIZE(ptab1,2)
427	zjpk = SIZE(ptab1,3)
428	!
429	ztmp = 0.e0
430	ctmp = CMPLX( 0.e0, 0.e0, wp )
431	DO jk = 1, zjpk
432	DO jj = 1, zjpj
433	DO ji =1, zjpi
434	ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj)
435	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
436	ztmp = ptab2(ji,jj,jk) * tmask_i(ji,jj)
437	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
438	END DO
439	END DO
440	END DO
441	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
442	glob_sum_3d_a = REAL(ctmp,wp)
443	!
444	END FUNCTION glob_sum_3d_a
445
446
447	! --- MIN ---
448	FUNCTION glob_min_2d( ptab )
449	!!----------------------------------------------------------------------
450	!! * FUNCTION glob_min_2d *
451	!!
452	!! ** Purpose : perform a min in calling DDPDD routine
453	!!----------------------------------------------------------------------
454	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab
455	REAL(wp) :: glob_min_2d ! global masked min
456	!!
457	COMPLEX(wp):: ctmp
458	REAL(wp) :: ztmp
459	INTEGER :: ji, jj ! dummy loop indices
460	INTEGER :: zjpi, zjpj ! local variables: size of ptab
461	!!-----------------------------------------------------------------------
462	zjpi = SIZE(ptab,1)
463	zjpj = SIZE(ptab,2)
464	!
465	ztmp = 0.e0
466	ctmp = CMPLX( 0.e0, 0.e0, wp )
467	DO jj = 1, zjpj
468	DO ji =1, zjpi
469	ztmp = ptab(ji,jj) * tmask_i(ji,jj)
470	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
471	END DO
472	END DO
473	IF( lk_mpp ) CALL mpp_min( ctmp ) ! min over the global domain
474	glob_min_2d = REAL(ctmp,wp)
475	!
476	END FUNCTION glob_min_2d
477
478
479	FUNCTION glob_min_3d( ptab )
480	!!----------------------------------------------------------------------
481	!! * FUNCTION glob_min_3d *
482	!!
483	!! ** Purpose : perform a min on a 3D array in calling DDPDD routine
484	!!----------------------------------------------------------------------
485	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab
486	REAL(wp) :: glob_min_3d ! global masked min
487	!!
488	COMPLEX(wp):: ctmp
489	REAL(wp) :: ztmp
490	INTEGER :: ji, jj, jk ! dummy loop indices
491	INTEGER :: zjpi, zjpj, zjpk ! local variables: size of ptab
492	!!-----------------------------------------------------------------------
493	!
494	zjpi = SIZE(ptab,1)
495	zjpj = SIZE(ptab,2)
496	zjpk = SIZE(ptab,3)
497	!
498	ztmp = 0.e0
499	ctmp = CMPLX( 0.e0, 0.e0, wp )
500	DO jk = 1, zjpk
501	DO jj = 1, zjpj
502	DO ji =1, zjpi
503	ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj)
504	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
505	END DO
506	END DO
507	END DO
508	IF( lk_mpp ) CALL mpp_min( ctmp ) ! min over the global domain
509	glob_min_3d = REAL(ctmp,wp)
510	!
511	END FUNCTION glob_min_3d
512
513
514	FUNCTION glob_min_2d_a( ptab1, ptab2 )
515	!!----------------------------------------------------------------------
516	!! * FUNCTION glob_min_2d_a *
517	!!
518	!! ** Purpose : perform a min on two 2D arrays in calling DDPDD routine
519	!!----------------------------------------------------------------------
520	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2
521	REAL(wp) :: glob_min_2d_a ! global masked min
522	!!
523	COMPLEX(wp):: ctmp
524	REAL(wp) :: ztmp
525	INTEGER :: ji, jj ! dummy loop indices
526	INTEGER :: zjpi, zjpj ! local variables: size of ptab
527	!!-----------------------------------------------------------------------
528	!
529	zjpi = SIZE(ptab1,1)
530	zjpj = SIZE(ptab1,2)
531	!
532	ztmp = 0.e0
533	ctmp = CMPLX( 0.e0, 0.e0, wp )
534	DO jj = 1, zjpj
535	DO ji =1, zjpi
536	ztmp = ptab1(ji,jj) * tmask_i(ji,jj)
537	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
538	ztmp = ptab2(ji,jj) * tmask_i(ji,jj)
539	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
540	END DO
541	END DO
542	IF( lk_mpp ) CALL mpp_min( ctmp ) ! min over the global domain
543	glob_min_2d_a = REAL(ctmp,wp)
544	!
545	END FUNCTION glob_min_2d_a
546
547
548	FUNCTION glob_min_3d_a( ptab1, ptab2 )
549	!!----------------------------------------------------------------------
550	!! * FUNCTION glob_min_3d_a *
551	!!
552	!! ** Purpose : perform a min on two 3D array in calling DDPDD routine
553	!!----------------------------------------------------------------------
554	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2
555	REAL(wp) :: glob_min_3d_a ! global masked min
556	!!
557	COMPLEX(wp):: ctmp
558	REAL(wp) :: ztmp
559	INTEGER :: ji, jj, jk ! dummy loop indices
560	INTEGER :: zjpi, zjpj, zjpk ! local variables: size of ptab
561	!!-----------------------------------------------------------------------
562	!
563	zjpi = SIZE(ptab1,1)
564	zjpj = SIZE(ptab1,2)
565	zjpk = SIZE(ptab1,3)
566	!
567	ztmp = 0.e0
568	ctmp = CMPLX( 0.e0, 0.e0, wp )
569	DO jk = 1, zjpk
570	DO jj = 1, zjpj
571	DO ji =1, zjpi
572	ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj)
573	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
574	ztmp = ptab2(ji,jj,jk) * tmask_i(ji,jj)
575	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
576	END DO
577	END DO
578	END DO
579	IF( lk_mpp ) CALL mpp_min( ctmp ) ! min over the global domain
580	glob_min_3d_a = REAL(ctmp,wp)
581	!
582	END FUNCTION glob_min_3d_a
583
584
585	! --- MAX ---
586	FUNCTION glob_max_2d( ptab )
587	!!----------------------------------------------------------------------
588	!! * FUNCTION glob_max_2d *
589	!!
590	!! ** Purpose : perform a max in calling DDPDD routine
591	!!----------------------------------------------------------------------
592	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab
593	REAL(wp) :: glob_max_2d ! global masked max
594	!!
595	COMPLEX(wp):: ctmp
596	REAL(wp) :: ztmp
597	INTEGER :: ji, jj ! dummy loop indices
598	INTEGER :: zjpi, zjpj ! local variables: size of ptab
599	!!-----------------------------------------------------------------------
600	zjpi = SIZE(ptab,1)
601	zjpj = SIZE(ptab,2)
602	!
603	ztmp = 0.e0
604	ctmp = CMPLX( 0.e0, 0.e0, wp )
605	DO jj = 1, zjpj
606	DO ji =1, zjpi
607	ztmp = ptab(ji,jj) * tmask_i(ji,jj)
608	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
609	END DO
610	END DO
611	IF( lk_mpp ) CALL mpp_max( ctmp ) ! max over the global domain
612	glob_max_2d = REAL(ctmp,wp)
613	!
614	END FUNCTION glob_max_2d
615
616
617	FUNCTION glob_max_3d( ptab )
618	!!----------------------------------------------------------------------
619	!! * FUNCTION glob_max_3d *
620	!!
621	!! ** Purpose : perform a max on a 3D array in calling DDPDD routine
622	!!----------------------------------------------------------------------
623	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab
624	REAL(wp) :: glob_max_3d ! global masked max
625	!!
626	COMPLEX(wp):: ctmp
627	REAL(wp) :: ztmp
628	INTEGER :: ji, jj, jk ! dummy loop indices
629	INTEGER :: zjpi, zjpj, zjpk ! local variables: size of ptab
630	!!-----------------------------------------------------------------------
631	!
632	zjpi = SIZE(ptab,1)
633	zjpj = SIZE(ptab,2)
634	zjpk = SIZE(ptab,3)
635	!
636	ztmp = 0.e0
637	ctmp = CMPLX( 0.e0, 0.e0, wp )
638	DO jk = 1, zjpk
639	DO jj = 1, zjpj
640	DO ji =1, zjpi
641	ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj)
642	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
643	END DO
644	END DO
645	END DO
646	IF( lk_mpp ) CALL mpp_max( ctmp ) ! max over the global domain
647	glob_max_3d = REAL(ctmp,wp)
648	!
649	END FUNCTION glob_max_3d
650
651
652	FUNCTION glob_max_2d_a( ptab1, ptab2 )
653	!!----------------------------------------------------------------------
654	!! * FUNCTION glob_max_2d_a *
655	!!
656	!! ** Purpose : perform a max on two 2D arrays in calling DDPDD routine
657	!!----------------------------------------------------------------------
658	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2
659	REAL(wp) :: glob_max_2d_a ! global masked max
660	!!
661	COMPLEX(wp):: ctmp
662	REAL(wp) :: ztmp
663	INTEGER :: ji, jj ! dummy loop indices
664	INTEGER :: zjpi, zjpj ! local variables: size of ptab
665	!!-----------------------------------------------------------------------
666	!
667	zjpi = SIZE(ptab1,1)
668	zjpj = SIZE(ptab1,2)
669	!
670	ztmp = 0.e0
671	ctmp = CMPLX( 0.e0, 0.e0, wp )
672	DO jj = 1, zjpj
673	DO ji =1, zjpi
674	ztmp = ptab1(ji,jj) * tmask_i(ji,jj)
675	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
676	ztmp = ptab2(ji,jj) * tmask_i(ji,jj)
677	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
678	END DO
679	END DO
680	IF( lk_mpp ) CALL mpp_max( ctmp ) ! max over the global domain
681	glob_max_2d_a = REAL(ctmp,wp)
682	!
683	END FUNCTION glob_max_2d_a
684
685
686	FUNCTION glob_max_3d_a( ptab1, ptab2 )
687	!!----------------------------------------------------------------------
688	!! * FUNCTION glob_max_3d_a *
689	!!
690	!! ** Purpose : perform a max on two 3D array in calling DDPDD routine
691	!!----------------------------------------------------------------------
692	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2
693	REAL(wp) :: glob_max_3d_a ! global masked max
694	!!
695	COMPLEX(wp):: ctmp
696	REAL(wp) :: ztmp
697	INTEGER :: ji, jj, jk ! dummy loop indices
698	INTEGER :: zjpi, zjpj, zjpk ! local variables: size of ptab
699	!!-----------------------------------------------------------------------
700	!
701	zjpi = SIZE(ptab1,1)
702	zjpj = SIZE(ptab1,2)
703	zjpk = SIZE(ptab1,3)
704	!
705	ztmp = 0.e0
706	ctmp = CMPLX( 0.e0, 0.e0, wp )
707	DO jk = 1, zjpk
708	DO jj = 1, zjpj
709	DO ji =1, zjpi
710	ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj)
711	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
712	ztmp = ptab2(ji,jj,jk) * tmask_i(ji,jj)
713	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
714	END DO
715	END DO
716	END DO
717	IF( lk_mpp ) CALL mpp_max( ctmp ) ! max over the global domain
718	glob_max_3d_a = REAL(ctmp,wp)
719	!
720	END FUNCTION glob_max_3d_a
721
722
723	SUBROUTINE DDPDD( ydda, yddb )
724	!!----------------------------------------------------------------------
725	!! * ROUTINE DDPDD *
726	!!
727	!! ** Purpose : Add a scalar element to a sum
728	!!
729	!!
730	!! ** Method : The code uses the compensated summation with doublet
731	!! (sum,error) emulated useing complex numbers. ydda is the
732	!! scalar to add to the summ yddb
733	!!
734	!! ** Action : This does only work for MPI.
735	!!
736	!! References : Using Acurate Arithmetics to Improve Numerical
737	!! Reproducibility and Sability in Parallel Applications
738	!! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
739	!!----------------------------------------------------------------------
740	COMPLEX(wp), INTENT(in ) :: ydda
741	COMPLEX(wp), INTENT(inout) :: yddb
742	!
743	REAL(wp) :: zerr, zt1, zt2 ! local work variables
744	!!-----------------------------------------------------------------------
745	!
746	! Compute ydda + yddb using Knuth's trick.
747	zt1 = REAL(ydda) + REAL(yddb)
748	zerr = zt1 - REAL(ydda)
749	zt2 = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) ) &
750	& + AIMAG(ydda) + AIMAG(yddb)
751	!
752	! The result is t1 + t2, after normalization.
753	yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
754	!
755	END SUBROUTINE DDPDD
756	#endif
757
758	#if defined key_nosignedzero
759	!!----------------------------------------------------------------------
760	!! 'key_nosignedzero' F90 SIGN
761	!!----------------------------------------------------------------------
762
763	FUNCTION SIGN_SCALAR( pa, pb )
764	!!-----------------------------------------------------------------------
765	!! * FUNCTION SIGN_SCALAR *
766	!!
767	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
768	!!-----------------------------------------------------------------------
769	REAL(wp) :: pa,pb ! input
770	REAL(wp) :: SIGN_SCALAR ! result
771	!!-----------------------------------------------------------------------
772	IF ( pb >= 0.e0) THEN ; SIGN_SCALAR = ABS(pa)
773	ELSE ; SIGN_SCALAR =-ABS(pa)
774	ENDIF
775	END FUNCTION SIGN_SCALAR
776
777
778	FUNCTION SIGN_ARRAY_1D( pa, pb )
779	!!-----------------------------------------------------------------------
780	!! * FUNCTION SIGN_ARRAY_1D *
781	!!
782	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
783	!!-----------------------------------------------------------------------
784	REAL(wp) :: pa,pb(:) ! input
785	REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1)) ! result
786	!!-----------------------------------------------------------------------
787	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D = ABS(pa)
788	ELSEWHERE ; SIGN_ARRAY_1D =-ABS(pa)
789	END WHERE
790	END FUNCTION SIGN_ARRAY_1D
791
792
793	FUNCTION SIGN_ARRAY_2D(pa,pb)
794	!!-----------------------------------------------------------------------
795	!! * FUNCTION SIGN_ARRAY_2D *
796	!!
797	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
798	!!-----------------------------------------------------------------------
799	REAL(wp) :: pa,pb(:,:) ! input
800	REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2)) ! result
801	!!-----------------------------------------------------------------------
802	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D = ABS(pa)
803	ELSEWHERE ; SIGN_ARRAY_2D =-ABS(pa)
804	END WHERE
805	END FUNCTION SIGN_ARRAY_2D
806
807	FUNCTION SIGN_ARRAY_3D(pa,pb)
808	!!-----------------------------------------------------------------------
809	!! * FUNCTION SIGN_ARRAY_3D *
810	!!
811	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
812	!!-----------------------------------------------------------------------
813	REAL(wp) :: pa,pb(:,:,:) ! input
814	REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
815	!!-----------------------------------------------------------------------
816	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D = ABS(pa)
817	ELSEWHERE ; SIGN_ARRAY_3D =-ABS(pa)
818	END WHERE
819	END FUNCTION SIGN_ARRAY_3D
820
821
822	FUNCTION SIGN_ARRAY_1D_A(pa,pb)
823	!!-----------------------------------------------------------------------
824	!! * FUNCTION SIGN_ARRAY_1D_A *
825	!!
826	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
827	!!-----------------------------------------------------------------------
828	REAL(wp) :: pa(:),pb(:) ! input
829	REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1)) ! result
830	!!-----------------------------------------------------------------------
831	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D_A = ABS(pa)
832	ELSEWHERE ; SIGN_ARRAY_1D_A =-ABS(pa)
833	END WHERE
834	END FUNCTION SIGN_ARRAY_1D_A
835
836
837	FUNCTION SIGN_ARRAY_2D_A(pa,pb)
838	!!-----------------------------------------------------------------------
839	!! * FUNCTION SIGN_ARRAY_2D_A *
840	!!
841	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
842	!!-----------------------------------------------------------------------
843	REAL(wp) :: pa(:,:),pb(:,:) ! input
844	REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2)) ! result
845	!!-----------------------------------------------------------------------
846	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D_A = ABS(pa)
847	ELSEWHERE ; SIGN_ARRAY_2D_A =-ABS(pa)
848	END WHERE
849	END FUNCTION SIGN_ARRAY_2D_A
850
851
852	FUNCTION SIGN_ARRAY_3D_A(pa,pb)
853	!!-----------------------------------------------------------------------
854	!! * FUNCTION SIGN_ARRAY_3D_A *
855	!!
856	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
857	!!-----------------------------------------------------------------------
858	REAL(wp) :: pa(:,:,:),pb(:,:,:) ! input
859	REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
860	!!-----------------------------------------------------------------------
861	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D_A = ABS(pa)
862	ELSEWHERE ; SIGN_ARRAY_3D_A =-ABS(pa)
863	END WHERE
864	END FUNCTION SIGN_ARRAY_3D_A
865
866
867	FUNCTION SIGN_ARRAY_1D_B(pa,pb)
868	!!-----------------------------------------------------------------------
869	!! * FUNCTION SIGN_ARRAY_1D_B *
870	!!
871	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
872	!!-----------------------------------------------------------------------
873	REAL(wp) :: pa(:),pb ! input
874	REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1)) ! result
875	!!-----------------------------------------------------------------------
876	IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_1D_B = ABS(pa)
877	ELSE ; SIGN_ARRAY_1D_B =-ABS(pa)
878	ENDIF
879	END FUNCTION SIGN_ARRAY_1D_B
880
881
882	FUNCTION SIGN_ARRAY_2D_B(pa,pb)
883	!!-----------------------------------------------------------------------
884	!! * FUNCTION SIGN_ARRAY_2D_B *
885	!!
886	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
887	!!-----------------------------------------------------------------------
888	REAL(wp) :: pa(:,:),pb ! input
889	REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2)) ! result
890	!!-----------------------------------------------------------------------
891	IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_2D_B = ABS(pa)
892	ELSE ; SIGN_ARRAY_2D_B =-ABS(pa)
893	ENDIF
894	END FUNCTION SIGN_ARRAY_2D_B
895
896
897	FUNCTION SIGN_ARRAY_3D_B(pa,pb)
898	!!-----------------------------------------------------------------------
899	!! * FUNCTION SIGN_ARRAY_3D_B *
900	!!
901	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
902	!!-----------------------------------------------------------------------
903	REAL(wp) :: pa(:,:,:),pb ! input
904	REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3)) ! result
905	!!-----------------------------------------------------------------------
906	IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_3D_B = ABS(pa)
907	ELSE ; SIGN_ARRAY_3D_B =-ABS(pa)
908	ENDIF
909	END FUNCTION SIGN_ARRAY_3D_B
910	#endif
911
912	!!======================================================================
913	END MODULE lib_fortran

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

Download in other formats: