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

Context Navigation

source: branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90 @ 5619

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

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

Download in other formats: