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

Last change on this file since 4036 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

Rev	Line
[2003]	1	MODULE lib_fortran
	2	!!======================================================================
	3	!! * MODULE lib_fortran *
	4	!! Fortran utilities: includes some low levels fortran functionality
	5	!!======================================================================
[2307]	6	!! History : 3.2 ! 2010-05 (M. Dunphy, R. Benshila) Original code
[4036]	7	!! 3.4 ! 2013-06 (C. Rousset) add glob_min, glob_max
	8	!! + 3d dim. of input is fexible (jpk, jpl...)
[2003]	9	!!----------------------------------------------------------------------
[2307]	10
[2003]	11	!!----------------------------------------------------------------------
[3764]	12	!! glob_sum : generic interface for global masked summation over
[2307]	13	!! the interior domain for 1 or 2 2D or 3D arrays
[3764]	14	!! it works only for T points
[2307]	15	!! SIGN : generic interface for SIGN to overwrite f95 behaviour
	16	!! of intrinsinc sign function
	17	!!----------------------------------------------------------------------
[3632]	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
[2003]	22
	23	IMPLICIT NONE
	24	PRIVATE
	25
[3632]	26	PUBLIC glob_sum ! used in many places
[4036]	27	PUBLIC glob_min, glob_max
[3632]	28	PUBLIC DDPDD ! also used in closea module
[2341]	29	#if defined key_nosignedzero
[2003]	30	PUBLIC SIGN
	31	#endif
	32
	33	INTERFACE glob_sum
[3764]	34	MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, &
	35	& glob_sum_2d_a, glob_sum_3d_a
[2003]	36	END INTERFACE
[4036]	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
[2003]	43
[3764]	44	#if defined key_nosignedzero
[2003]	45	INTERFACE SIGN
[2307]	46	MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D, &
[3764]	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
[2003]	49	END INTERFACE
	50	#endif
	51
[2307]	52	!!----------------------------------------------------------------------
	53	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
[3764]	54	!! $Id$
[2307]	55	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	56	!!----------------------------------------------------------------------
[3764]	57	CONTAINS
[2003]	58
[2307]	59	#if ! defined key_mpp_rep
[4036]	60	! --- SUM ---
	61
[3764]	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
[3632]	77
[3764]	78	FUNCTION glob_sum_2d( ptab )
[2003]	79	!!-----------------------------------------------------------------------
	80	!! * FUNCTION glob_sum_2D *
	81	!!
[2307]	82	!! ** Purpose : perform a masked sum on the inner global domain of a 2D array
[2003]	83	!!-----------------------------------------------------------------------
[3294]	84	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array
	85	REAL(wp) :: glob_sum_2d ! global masked sum
[2003]	86	!!-----------------------------------------------------------------------
[2307]	87	!
[3294]	88	glob_sum_2d = SUM( ptab(:,:)*tmask_i(:,:) )
	89	IF( lk_mpp ) CALL mpp_sum( glob_sum_2d )
[2307]	90	!
[2003]	91	END FUNCTION glob_sum_2d
[3764]	92
	93
	94	FUNCTION glob_sum_3d( ptab )
[2003]	95	!!-----------------------------------------------------------------------
	96	!! * FUNCTION glob_sum_3D *
	97	!!
[2307]	98	!! ** Purpose : perform a masked sum on the inner global domain of a 3D array
[2003]	99	!!-----------------------------------------------------------------------
[3294]	100	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array
	101	REAL(wp) :: glob_sum_3d ! global masked sum
[2307]	102	!!
[2003]	103	INTEGER :: jk
[4036]	104	INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
[2003]	105	!!-----------------------------------------------------------------------
[2307]	106	!
[4036]	107	ijpk = SIZE(ptab,3)
	108	!
[3294]	109	glob_sum_3d = 0.e0
[4036]	110	DO jk = 1, ijpk
[3294]	111	glob_sum_3d = glob_sum_3d + SUM( ptab(:,:,jk)*tmask_i(:,:) )
[2003]	112	END DO
[3294]	113	IF( lk_mpp ) CALL mpp_sum( glob_sum_3d )
[2307]	114	!
[2003]	115	END FUNCTION glob_sum_3d
	116
[2307]	117
[3764]	118	FUNCTION glob_sum_2d_a( ptab1, ptab2 )
[2003]	119	!!-----------------------------------------------------------------------
	120	!! * FUNCTION glob_sum_2D _a *
	121	!!
[2307]	122	!! ** Purpose : perform a masked sum on the inner global domain of two 2D array
[2003]	123	!!-----------------------------------------------------------------------
[3294]	124	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array
	125	REAL(wp) , DIMENSION(2) :: glob_sum_2d_a ! global masked sum
[2003]	126	!!-----------------------------------------------------------------------
[3764]	127	!
[3294]	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 )
[2307]	131	!
[2003]	132	END FUNCTION glob_sum_2d_a
[3764]	133
	134
	135	FUNCTION glob_sum_3d_a( ptab1, ptab2 )
[2003]	136	!!-----------------------------------------------------------------------
	137	!! * FUNCTION glob_sum_3D_a *
	138	!!
[2307]	139	!! ** Purpose : perform a masked sum on the inner global domain of two 3D array
[2003]	140	!!-----------------------------------------------------------------------
[3294]	141	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array
	142	REAL(wp) , DIMENSION(2) :: glob_sum_3d_a ! global masked sum
[2307]	143	!!
[2003]	144	INTEGER :: jk
[4036]	145	INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
[2003]	146	!!-----------------------------------------------------------------------
[2307]	147	!
[4036]	148	ijpk = SIZE(ptab1,3)
	149	!
[3294]	150	glob_sum_3d_a(:) = 0.e0
[4036]	151	DO jk = 1, ijpk
[3294]	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(:,:) )
[2003]	154	END DO
[3294]	155	IF( lk_mpp ) CALL mpp_sum( glob_sum_3d_a, 2 )
[2307]	156	!
[2003]	157	END FUNCTION glob_sum_3d_a
	158
[4036]	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
[2307]	323	!!----------------------------------------------------------------------
	324	!! 'key_mpp_rep' MPP reproducibility
	325	!!----------------------------------------------------------------------
[4036]	326
	327	! --- SUM ---
[3764]	328	FUNCTION glob_sum_1d( ptab, kdim )
[2003]	329	!!----------------------------------------------------------------------
[3764]	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	!!----------------------------------------------------------------------
[2307]	356	!! * FUNCTION glob_sum_2d *
[2003]	357	!!
	358	!! ** Purpose : perform a sum in calling DDPDD routine
[2307]	359	!!----------------------------------------------------------------------
[4036]	360	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab
	361	REAL(wp) :: glob_sum_2d ! global masked sum
[2003]	362	!!
[2307]	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
[3294]	377	glob_sum_2d = REAL(ctmp,wp)
[2307]	378	!
[3764]	379	END FUNCTION glob_sum_2d
[2307]	380
	381
[3764]	382	FUNCTION glob_sum_3d( ptab )
[2003]	383	!!----------------------------------------------------------------------
[2307]	384	!! * FUNCTION glob_sum_3d *
	385	!!
	386	!! ** Purpose : perform a sum on a 3D array in calling DDPDD routine
	387	!!----------------------------------------------------------------------
[4036]	388	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab
	389	REAL(wp) :: glob_sum_3d ! global masked sum
[2307]	390	!!
	391	COMPLEX(wp):: ctmp
	392	REAL(wp) :: ztmp
	393	INTEGER :: ji, jj, jk ! dummy loop indices
[4036]	394	INTEGER :: ijpk ! local variables: size of ptab
[2307]	395	!!-----------------------------------------------------------------------
[2003]	396	!
[4036]	397	ijpk = SIZE(ptab,3)
	398	!
[2307]	399	ztmp = 0.e0
	400	ctmp = CMPLX( 0.e0, 0.e0, wp )
[4036]	401	DO jk = 1, ijpk
[2307]	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
[3764]	407	END DO
[2307]	408	END DO
	409	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
[3294]	410	glob_sum_3d = REAL(ctmp,wp)
[2307]	411	!
[3764]	412	END FUNCTION glob_sum_3d
[2307]	413
	414
[3764]	415	FUNCTION glob_sum_2d_a( ptab1, ptab2 )
[2307]	416	!!----------------------------------------------------------------------
	417	!! * FUNCTION glob_sum_2d_a *
	418	!!
	419	!! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine
	420	!!----------------------------------------------------------------------
[4036]	421	REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2
	422	REAL(wp) :: glob_sum_2d_a ! global masked sum
[2307]	423	!!
	424	COMPLEX(wp):: ctmp
	425	REAL(wp) :: ztmp
	426	INTEGER :: ji, jj ! dummy loop indices
[2003]	427	!!-----------------------------------------------------------------------
[2307]	428	!
[2003]	429	ztmp = 0.e0
[2307]	430	ctmp = CMPLX( 0.e0, 0.e0, wp )
	431	DO jj = 1, jpj
[2003]	432	DO ji =1, jpi
[2307]	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 )
[2003]	437	END DO
	438	END DO
	439	IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain
[3294]	440	glob_sum_2d_a = REAL(ctmp,wp)
[2307]	441	!
[3764]	442	END FUNCTION glob_sum_2d_a
[2003]	443
[2307]	444
[3764]	445	FUNCTION glob_sum_3d_a( ptab1, ptab2 )
[2307]	446	!!----------------------------------------------------------------------
	447	!! * FUNCTION glob_sum_3d_a *
	448	!!
	449	!! ** Purpose : perform a sum on two 3D array in calling DDPDD routine
	450	!!----------------------------------------------------------------------
[4036]	451	REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2
	452	REAL(wp) :: glob_sum_3d_a ! global masked sum
[2307]	453	!!
	454	COMPLEX(wp):: ctmp
	455	REAL(wp) :: ztmp
	456	INTEGER :: ji, jj, jk ! dummy loop indices
[4036]	457	INTEGER :: ijpk ! local variables: size of ptab
[2307]	458	!!-----------------------------------------------------------------------
	459	!
[4036]	460	ijpk = SIZE(ptab1,3)
	461	!
[2307]	462	ztmp = 0.e0
	463	ctmp = CMPLX( 0.e0, 0.e0, wp )
[4036]	464	DO jk = 1, ijpk
[2307]	465	DO jj = 1, jpj
[4036]	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)
[2307]	500	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
[4036]	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)
[2307]	562	CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
[4036]	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 )
[2307]	599	END DO
[4036]	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 )
[3764]	629	END DO
[2307]	630	END DO
[4036]	631	IF( lk_mpp ) CALL mpp_max( ctmp ) ! max over the global domain
	632	glob_max_2d = REAL(ctmp,wp)
[2307]	633	!
[4036]	634	END FUNCTION glob_max_2d
[2307]	635
[4036]	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
[3632]	735	#endif
[2307]	736
[2003]	737	SUBROUTINE DDPDD( ydda, yddb )
	738	!!----------------------------------------------------------------------
	739	!! * ROUTINE DDPDD *
[3764]	740	!!
[2003]	741	!! ** Purpose : Add a scalar element to a sum
	742	!!
[3764]	743	!!
	744	!! ** Method : The code uses the compensated summation with doublet
[2003]	745	!! (sum,error) emulated useing complex numbers. ydda is the
[3764]	746	!! scalar to add to the summ yddb
[2003]	747	!!
[3764]	748	!! ** Action : This does only work for MPI.
	749	!!
[2003]	750	!! References : Using Acurate Arithmetics to Improve Numerical
	751	!! Reproducibility and Sability in Parallel Applications
[3764]	752	!! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
[2003]	753	!!----------------------------------------------------------------------
[2307]	754	COMPLEX(wp), INTENT(in ) :: ydda
	755	COMPLEX(wp), INTENT(inout) :: yddb
	756	!
[2003]	757	REAL(wp) :: zerr, zt1, zt2 ! local work variables
[2307]	758	!!-----------------------------------------------------------------------
	759	!
[2003]	760	! Compute ydda + yddb using Knuth's trick.
[2307]	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	!
[2003]	766	! The result is t1 + t2, after normalization.
[2307]	767	yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
	768	!
[2003]	769	END SUBROUTINE DDPDD
	770
	771	#if defined key_nosignedzero
[2307]	772	!!----------------------------------------------------------------------
	773	!! 'key_nosignedzero' F90 SIGN
	774	!!----------------------------------------------------------------------
[3764]	775
[2307]	776	FUNCTION SIGN_SCALAR( pa, pb )
[2003]	777	!!-----------------------------------------------------------------------
	778	!! * FUNCTION SIGN_SCALAR *
	779	!!
	780	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
	781	!!-----------------------------------------------------------------------
	782	REAL(wp) :: pa,pb ! input
[2307]	783	REAL(wp) :: SIGN_SCALAR ! result
	784	!!-----------------------------------------------------------------------
	785	IF ( pb >= 0.e0) THEN ; SIGN_SCALAR = ABS(pa)
	786	ELSE ; SIGN_SCALAR =-ABS(pa)
[2003]	787	ENDIF
	788	END FUNCTION SIGN_SCALAR
	789
[2307]	790
[3764]	791	FUNCTION SIGN_ARRAY_1D( pa, pb )
[2003]	792	!!-----------------------------------------------------------------------
	793	!! * FUNCTION SIGN_ARRAY_1D *
	794	!!
	795	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
	796	!!-----------------------------------------------------------------------
[2307]	797	REAL(wp) :: pa,pb(:) ! input
[2003]	798	REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1)) ! result
[2307]	799	!!-----------------------------------------------------------------------
	800	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D = ABS(pa)
	801	ELSEWHERE ; SIGN_ARRAY_1D =-ABS(pa)
[2003]	802	END WHERE
	803	END FUNCTION SIGN_ARRAY_1D
	804
[2307]	805
[3764]	806	FUNCTION SIGN_ARRAY_2D(pa,pb)
[2003]	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
[2307]	814	!!-----------------------------------------------------------------------
	815	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D = ABS(pa)
	816	ELSEWHERE ; SIGN_ARRAY_2D =-ABS(pa)
[2003]	817	END WHERE
	818	END FUNCTION SIGN_ARRAY_2D
	819
[3764]	820	FUNCTION SIGN_ARRAY_3D(pa,pb)
[2003]	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
[2307]	828	!!-----------------------------------------------------------------------
	829	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D = ABS(pa)
	830	ELSEWHERE ; SIGN_ARRAY_3D =-ABS(pa)
[2003]	831	END WHERE
	832	END FUNCTION SIGN_ARRAY_3D
	833
[2307]	834
[3764]	835	FUNCTION SIGN_ARRAY_1D_A(pa,pb)
[2003]	836	!!-----------------------------------------------------------------------
	837	!! * FUNCTION SIGN_ARRAY_1D_A *
	838	!!
	839	!! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
	840	!!-----------------------------------------------------------------------
	841	REAL(wp) :: pa(:),pb(:) ! input
[2307]	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)
[2003]	846	END WHERE
	847	END FUNCTION SIGN_ARRAY_1D_A
	848
[2307]	849
[3764]	850	FUNCTION SIGN_ARRAY_2D_A(pa,pb)
[2003]	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
[2307]	858	!!-----------------------------------------------------------------------
	859	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D_A = ABS(pa)
	860	ELSEWHERE ; SIGN_ARRAY_2D_A =-ABS(pa)
[2003]	861	END WHERE
	862	END FUNCTION SIGN_ARRAY_2D_A
	863
[2307]	864
[3764]	865	FUNCTION SIGN_ARRAY_3D_A(pa,pb)
[2003]	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
[2307]	873	!!-----------------------------------------------------------------------
	874	WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D_A = ABS(pa)
	875	ELSEWHERE ; SIGN_ARRAY_3D_A =-ABS(pa)
[2003]	876	END WHERE
	877	END FUNCTION SIGN_ARRAY_3D_A
	878
[2307]	879
[3764]	880	FUNCTION SIGN_ARRAY_1D_B(pa,pb)
[2003]	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
[2307]	888	!!-----------------------------------------------------------------------
	889	IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_1D_B = ABS(pa)
	890	ELSE ; SIGN_ARRAY_1D_B =-ABS(pa)
[2003]	891	ENDIF
	892	END FUNCTION SIGN_ARRAY_1D_B
	893
[2307]	894
[3764]	895	FUNCTION SIGN_ARRAY_2D_B(pa,pb)
[2003]	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
[2307]	903	!!-----------------------------------------------------------------------
	904	IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_2D_B = ABS(pa)
	905	ELSE ; SIGN_ARRAY_2D_B =-ABS(pa)
[2003]	906	ENDIF
	907	END FUNCTION SIGN_ARRAY_2D_B
	908
[2307]	909
[3764]	910	FUNCTION SIGN_ARRAY_3D_B(pa,pb)
[2003]	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
[2307]	918	!!-----------------------------------------------------------------------
	919	IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_3D_B = ABS(pa)
	920	ELSE ; SIGN_ARRAY_3D_B =-ABS(pa)
[2003]	921	ENDIF
	922	END FUNCTION SIGN_ARRAY_3D_B
	923	#endif
	924
[2307]	925	!!======================================================================
[2003]	926	END MODULE lib_fortran

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

Download in other formats: