source: NEMO/trunk/src/OCE/lib_fortran.F90 @ 13324

Last change on this file since 13324 was 13324, checked in by acc, 14 months ago

Trunk changes to achieve reproducibility of tracer.stat files in SETTE with nn_hls=2. There is still an untraced dependency on nn_hls in the tracer.stat values but REPRO_4_8 and REPRO_8_4 are now in agreement for each set of runs with each value of nn_hls (with ln_icebergs=.false.

  • Property svn:keywords set to Id
File size: 20.5 KB
Line 
1MODULE 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   !!            4.0  !  2016-06  (T. Lovato)  double precision global sum by default
10   !!----------------------------------------------------------------------
11
12   !!----------------------------------------------------------------------
13   !!   glob_sum    : generic interface for global masked summation over
14   !!                 the interior domain for 1 or 2 2D or 3D arrays
15   !!                 it works only for T points
16   !!   SIGN        : generic interface for SIGN to overwrite f95 behaviour
17   !!                 of intrinsinc sign function
18   !!----------------------------------------------------------------------
19   USE par_oce         ! Ocean parameter
20   USE dom_oce         ! ocean domain
21   USE in_out_manager  ! I/O manager
22   USE lib_mpp         ! distributed memory computing
23   USE lbclnk          ! ocean lateral boundary conditions
24
25   IMPLICIT NONE
26   PRIVATE
27
28   PUBLIC   glob_sum      ! used in many places (masked with tmask_i)
29   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos)
30   PUBLIC   local_sum     ! used in trcrad, local operation before glob_sum_delay
31   PUBLIC   sum3x3        ! used in trcrad, do a sum over 3x3 boxes
32   PUBLIC   DDPDD         ! also used in closea module
33   PUBLIC   glob_min, glob_max
34#if defined key_nosignedzero
35   PUBLIC SIGN
36#endif
37
38   INTERFACE glob_sum
39      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d
40   END INTERFACE
41   INTERFACE glob_sum_full
42      MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d
43   END INTERFACE
44   INTERFACE local_sum
45      MODULE PROCEDURE local_sum_2d, local_sum_3d
46   END INTERFACE
47   INTERFACE sum3x3
48      MODULE PROCEDURE sum3x3_2d, sum3x3_3d
49   END INTERFACE
50   INTERFACE glob_min
51      MODULE PROCEDURE glob_min_2d, glob_min_3d
52   END INTERFACE
53   INTERFACE glob_max
54      MODULE PROCEDURE glob_max_2d, glob_max_3d
55   END INTERFACE
56
57#if defined key_nosignedzero
58   INTERFACE SIGN
59      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
60         &             SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,          &
61         &             SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B
62   END INTERFACE
63#endif
64
65   !! * Substitutions
66#  include "do_loop_substitute.h90"
67   !!----------------------------------------------------------------------
68   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
69   !! $Id$
70   !! Software governed by the CeCILL license (see ./LICENSE)
71   !!----------------------------------------------------------------------
72CONTAINS
73
74#  define GLOBSUM_CODE
75
76#     define DIM_1d
77#     define FUNCTION_GLOBSUM           glob_sum_1d
78#     include "lib_fortran_generic.h90"
79#     undef FUNCTION_GLOBSUM
80#     undef DIM_1d
81
82#     define DIM_2d
83#     define OPERATION_GLOBSUM
84#     define FUNCTION_GLOBSUM           glob_sum_2d
85#     include "lib_fortran_generic.h90"
86#     undef FUNCTION_GLOBSUM
87#     undef OPERATION_GLOBSUM
88#     define OPERATION_FULL_GLOBSUM
89#     define FUNCTION_GLOBSUM           glob_sum_full_2d
90#     include "lib_fortran_generic.h90"
91#     undef FUNCTION_GLOBSUM
92#     undef OPERATION_FULL_GLOBSUM
93#     undef DIM_2d
94
95#     define DIM_3d
96#     define OPERATION_GLOBSUM
97#     define FUNCTION_GLOBSUM           glob_sum_3d
98#     include "lib_fortran_generic.h90"
99#     undef FUNCTION_GLOBSUM
100#     undef OPERATION_GLOBSUM
101#     define OPERATION_FULL_GLOBSUM
102#     define FUNCTION_GLOBSUM           glob_sum_full_3d
103#     include "lib_fortran_generic.h90"
104#     undef FUNCTION_GLOBSUM
105#     undef OPERATION_FULL_GLOBSUM
106#     undef DIM_3d
107
108#  undef GLOBSUM_CODE
109
110
111#  define GLOBMINMAX_CODE
112
113#     define DIM_2d
114#     define OPERATION_GLOBMIN
115#     define FUNCTION_GLOBMINMAX           glob_min_2d
116#     include "lib_fortran_generic.h90"
117#     undef FUNCTION_GLOBMINMAX
118#     undef OPERATION_GLOBMIN
119#     define OPERATION_GLOBMAX
120#     define FUNCTION_GLOBMINMAX           glob_max_2d
121#     include "lib_fortran_generic.h90"
122#     undef FUNCTION_GLOBMINMAX
123#     undef OPERATION_GLOBMAX
124#     undef DIM_2d
125
126#     define DIM_3d
127#     define OPERATION_GLOBMIN
128#     define FUNCTION_GLOBMINMAX           glob_min_3d
129#     include "lib_fortran_generic.h90"
130#     undef FUNCTION_GLOBMINMAX
131#     undef OPERATION_GLOBMIN
132#     define OPERATION_GLOBMAX
133#     define FUNCTION_GLOBMINMAX           glob_max_3d
134#     include "lib_fortran_generic.h90"
135#     undef FUNCTION_GLOBMINMAX
136#     undef OPERATION_GLOBMAX
137#     undef DIM_3d
138#  undef GLOBMINMAX_CODE
139
140!                          ! FUNCTION local_sum !
141
142   FUNCTION local_sum_2d( ptab )
143      !!----------------------------------------------------------------------
144      REAL(wp),  INTENT(in   ) ::   ptab(:,:) ! array on which operation is applied
145      COMPLEX(dp)              ::  local_sum_2d
146      !
147      !!-----------------------------------------------------------------------
148      !
149      COMPLEX(dp)::   ctmp
150      REAL(wp)   ::   ztmp
151      INTEGER    ::   ji, jj    ! dummy loop indices
152      INTEGER    ::   ipi, ipj  ! dimensions
153      !!-----------------------------------------------------------------------
154      !
155      ipi = SIZE(ptab,1)   ! 1st dimension
156      ipj = SIZE(ptab,2)   ! 2nd dimension
157      !
158      ctmp = CMPLX( 0.e0, 0.e0, wp )   ! warning ctmp is cumulated
159
160      DO jj = 1, ipj
161         DO ji = 1, ipi
162            ztmp =  ptab(ji,jj) * tmask_i(ji,jj)
163            CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
164         END DO
165      END DO
166      !
167      local_sum_2d = ctmp
168       
169   END FUNCTION local_sum_2d
170
171   FUNCTION local_sum_3d( ptab )
172      !!----------------------------------------------------------------------
173      REAL(wp),  INTENT(in   ) ::   ptab(:,:,:) ! array on which operation is applied
174      COMPLEX(dp)              ::  local_sum_3d
175      !
176      !!-----------------------------------------------------------------------
177      !
178      COMPLEX(dp)::   ctmp
179      REAL(wp)   ::   ztmp
180      INTEGER    ::   ji, jj, jk   ! dummy loop indices
181      INTEGER    ::   ipi, ipj, ipk    ! dimensions
182      !!-----------------------------------------------------------------------
183      !
184      ipi = SIZE(ptab,1)   ! 1st dimension
185      ipj = SIZE(ptab,2)   ! 2nd dimension
186      ipk = SIZE(ptab,3)   ! 3rd dimension
187      !
188      ctmp = CMPLX( 0.e0, 0.e0, wp )   ! warning ctmp is cumulated
189
190      DO jk = 1, ipk
191        DO jj = 1, ipj
192          DO ji = 1, ipi
193             ztmp =  ptab(ji,jj,jk) * tmask_i(ji,jj)
194             CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
195          END DO
196        END DO
197      END DO
198      !
199      local_sum_3d = ctmp
200       
201   END FUNCTION local_sum_3d
202
203!                          ! FUNCTION sum3x3 !
204
205   SUBROUTINE sum3x3_2d( p2d )
206      !!-----------------------------------------------------------------------
207      !!                  ***  routine sum3x3_2d  ***
208      !!
209      !! ** Purpose : sum over 3x3 boxes
210      !!----------------------------------------------------------------------
211      REAL(wp), DIMENSION (:,:), INTENT(inout) ::   p2d
212      !
213      INTEGER ::   ji, ji2, jj, jj2     ! dummy loop indices
214      !!----------------------------------------------------------------------
215      !
216      IF( SIZE(p2d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the first dimension is not equal to jpi' ) 
217      IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) 
218      !
219      ! work over the whole domain (guarantees all internal cells are set when nn_hls=2)
220      !
221      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
222         IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN   ! bottom left corner of a 3x3 box
223            ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
224            jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
225            IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
226               p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2))
227            ENDIF
228         ENDIF
229      END_2D
230      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
231      ! no need for 2nd exchange when nn_hls = 2
232      IF( nn_hls /= 2 ) THEN
233         IF( nbondi /= -1 ) THEN
234            IF( MOD(mig(    1), 3) == 1 )   p2d(    1,:) = p2d(    2,:)
235            IF( MOD(mig(    1), 3) == 2 )   p2d(    2,:) = p2d(    1,:)
236         ENDIF
237         IF( nbondi /=  1 ) THEN
238            IF( MOD(mig(jpi-2), 3) == 1 )   p2d(  jpi,:) = p2d(jpi-1,:)
239            IF( MOD(mig(jpi-2), 3) == 0 )   p2d(jpi-1,:) = p2d(  jpi,:)
240         ENDIF
241         IF( nbondj /= -1 ) THEN
242            IF( MOD(mjg(    1), 3) == 1 )   p2d(:,    1) = p2d(:,    2)
243            IF( MOD(mjg(    1), 3) == 2 )   p2d(:,    2) = p2d(:,    1)
244         ENDIF
245         IF( nbondj /=  1 ) THEN
246            IF( MOD(mjg(jpj-2), 3) == 1 )   p2d(:,  jpj) = p2d(:,jpj-1)
247            IF( MOD(mjg(jpj-2), 3) == 0 )   p2d(:,jpj-1) = p2d(:,  jpj)
248         ENDIF
249         CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
250      ENDIF
251
252   END SUBROUTINE sum3x3_2d
253
254   SUBROUTINE sum3x3_3d( p3d )
255      !!-----------------------------------------------------------------------
256      !!                  ***  routine sum3x3_3d  ***
257      !!
258      !! ** Purpose : sum over 3x3 boxes
259      !!----------------------------------------------------------------------
260      REAL(wp), DIMENSION (:,:,:), INTENT(inout) ::   p3d
261      !
262      INTEGER ::   ji, ji2, jj, jj2, jn     ! dummy loop indices
263      INTEGER ::   ipn                      ! Third dimension size
264      !!----------------------------------------------------------------------
265      !
266      IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) 
267      IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) 
268      ipn = SIZE(p3d,3)
269      !
270      DO jn = 1, ipn
271         !
272         ! work over the whole domain (guarantees all internal cells are set when nn_hls=2)
273         !
274         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
275            IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN   ! bottom left corner of a 3x3 box
276               ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
277               jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
278               IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
279                  p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn))
280               ENDIF
281            ENDIF
282         END_2D
283      END DO
284      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
285      ! no need for 2nd exchange when nn_hls = 2
286      IF( nn_hls /= 2 ) THEN
287         IF( nbondi /= -1 ) THEN
288            IF( MOD(mig(    1), 3) == 1 )   p3d(    1,:,:) = p3d(    2,:,:)
289            IF( MOD(mig(    1), 3) == 2 )   p3d(    2,:,:) = p3d(    1,:,:)
290         ENDIF
291         IF( nbondi /=  1 ) THEN
292            IF( MOD(mig(jpi-2), 3) == 1 )   p3d(  jpi,:,:) = p3d(jpi-1,:,:)
293            IF( MOD(mig(jpi-2), 3) == 0 )   p3d(jpi-1,:,:) = p3d(  jpi,:,:)
294         ENDIF
295         IF( nbondj /= -1 ) THEN
296            IF( MOD(mjg(    1), 3) == 1 )   p3d(:,    1,:) = p3d(:,    2,:)
297            IF( MOD(mjg(    1), 3) == 2 )   p3d(:,    2,:) = p3d(:,    1,:)
298         ENDIF
299         IF( nbondj /=  1 ) THEN
300            IF( MOD(mjg(jpj-2), 3) == 1 )   p3d(:,  jpj,:) = p3d(:,jpj-1,:)
301            IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:)
302         ENDIF
303         CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
304      ENDIF
305
306   END SUBROUTINE sum3x3_3d
307
308
309   SUBROUTINE DDPDD( ydda, yddb )
310      !!----------------------------------------------------------------------
311      !!               ***  ROUTINE DDPDD ***
312      !!
313      !! ** Purpose : Add a scalar element to a sum
314      !!
315      !!
316      !! ** Method  : The code uses the compensated summation with doublet
317      !!              (sum,error) emulated useing complex numbers. ydda is the
318      !!               scalar to add to the summ yddb
319      !!
320      !! ** Action  : This does only work for MPI.
321      !!
322      !! References : Using Acurate Arithmetics to Improve Numerical
323      !!              Reproducibility and Sability in Parallel Applications
324      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
325      !!----------------------------------------------------------------------
326      COMPLEX(dp), INTENT(in   ) ::   ydda
327      COMPLEX(dp), INTENT(inout) ::   yddb
328      !
329      REAL(dp) :: zerr, zt1, zt2  ! local work variables
330      !!-----------------------------------------------------------------------
331      !
332      ! Compute ydda + yddb using Knuth's trick.
333      zt1  = REAL(ydda) + REAL(yddb)
334      zerr = zt1 - REAL(ydda)
335      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
336         &   + AIMAG(ydda)         + AIMAG(yddb)
337      !
338      ! The result is t1 + t2, after normalization.
339      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
340      !
341   END SUBROUTINE DDPDD
342
343#if defined key_nosignedzero
344   !!----------------------------------------------------------------------
345   !!   'key_nosignedzero'                                         F90 SIGN
346   !!----------------------------------------------------------------------
347
348   FUNCTION SIGN_SCALAR( pa, pb )
349      !!-----------------------------------------------------------------------
350      !!                  ***  FUNCTION SIGN_SCALAR  ***
351      !!
352      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
353      !!-----------------------------------------------------------------------
354      REAL(wp) :: pa,pb          ! input
355      REAL(wp) :: SIGN_SCALAR    ! result
356      !!-----------------------------------------------------------------------
357      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
358      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
359      ENDIF
360   END FUNCTION SIGN_SCALAR
361
362
363   FUNCTION SIGN_ARRAY_1D( pa, pb )
364      !!-----------------------------------------------------------------------
365      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
366      !!
367      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
368      !!-----------------------------------------------------------------------
369      REAL(wp) :: pa,pb(:)                   ! input
370      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
371      !!-----------------------------------------------------------------------
372      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
373      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
374      END WHERE
375   END FUNCTION SIGN_ARRAY_1D
376
377
378   FUNCTION SIGN_ARRAY_2D(pa,pb)
379      !!-----------------------------------------------------------------------
380      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
381      !!
382      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
383      !!-----------------------------------------------------------------------
384      REAL(wp) :: pa,pb(:,:)      ! input
385      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
386      !!-----------------------------------------------------------------------
387      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
388      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
389      END WHERE
390   END FUNCTION SIGN_ARRAY_2D
391
392   FUNCTION SIGN_ARRAY_3D(pa,pb)
393      !!-----------------------------------------------------------------------
394      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
395      !!
396      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
397      !!-----------------------------------------------------------------------
398      REAL(wp) :: pa,pb(:,:,:)      ! input
399      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
400      !!-----------------------------------------------------------------------
401      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
402      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
403      END WHERE
404   END FUNCTION SIGN_ARRAY_3D
405
406
407   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
408      !!-----------------------------------------------------------------------
409      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
410      !!
411      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
412      !!-----------------------------------------------------------------------
413      REAL(wp) :: pa(:),pb(:)      ! input
414      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
415      !!-----------------------------------------------------------------------
416      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
417      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
418      END WHERE
419   END FUNCTION SIGN_ARRAY_1D_A
420
421
422   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
423      !!-----------------------------------------------------------------------
424      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
425      !!
426      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
427      !!-----------------------------------------------------------------------
428      REAL(wp) :: pa(:,:),pb(:,:)      ! input
429      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
430      !!-----------------------------------------------------------------------
431      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
432      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
433      END WHERE
434   END FUNCTION SIGN_ARRAY_2D_A
435
436
437   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
438      !!-----------------------------------------------------------------------
439      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
440      !!
441      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
442      !!-----------------------------------------------------------------------
443      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
444      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
445      !!-----------------------------------------------------------------------
446      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
447      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
448      END WHERE
449   END FUNCTION SIGN_ARRAY_3D_A
450
451
452   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
453      !!-----------------------------------------------------------------------
454      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
455      !!
456      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
457      !!-----------------------------------------------------------------------
458      REAL(wp) :: pa(:),pb      ! input
459      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
460      !!-----------------------------------------------------------------------
461      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
462      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
463      ENDIF
464   END FUNCTION SIGN_ARRAY_1D_B
465
466
467   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
468      !!-----------------------------------------------------------------------
469      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
470      !!
471      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
472      !!-----------------------------------------------------------------------
473      REAL(wp) :: pa(:,:),pb      ! input
474      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
475      !!-----------------------------------------------------------------------
476      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
477      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
478      ENDIF
479   END FUNCTION SIGN_ARRAY_2D_B
480
481
482   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
483      !!-----------------------------------------------------------------------
484      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
485      !!
486      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
487      !!-----------------------------------------------------------------------
488      REAL(wp) :: pa(:,:,:),pb      ! input
489      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
490      !!-----------------------------------------------------------------------
491      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
492      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
493      ENDIF
494   END FUNCTION SIGN_ARRAY_3D_B
495#endif
496
497   !!======================================================================
498END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.