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 NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE – NEMO

source: NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/lib_fortran.F90 @ 14644

Last change on this file since 14644 was 14644, checked in by sparonuz, 3 years ago

Merge trunk -r14642:HEAD
  • Property svn:keywords set to Id
File size: 20.3 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_sp, glob_sum_2d_sp, glob_sum_3d_sp
40      MODULE PROCEDURE glob_sum_1d_dp, glob_sum_2d_dp, glob_sum_3d_dp
41   END INTERFACE
42   INTERFACE glob_sum_full
43      MODULE PROCEDURE glob_sum_full_2d_sp, glob_sum_full_3d_sp
44      MODULE PROCEDURE glob_sum_full_2d_dp, glob_sum_full_3d_dp
45   END INTERFACE
46   INTERFACE local_sum
47      MODULE PROCEDURE local_sum_2d, local_sum_3d
48   END INTERFACE
49   INTERFACE sum3x3
50      MODULE PROCEDURE sum3x3_2d, sum3x3_3d
51   END INTERFACE
52   INTERFACE glob_min
53      MODULE PROCEDURE glob_min_2d_sp, glob_min_3d_sp
54      MODULE PROCEDURE glob_min_2d_dp, glob_min_3d_dp
55   END INTERFACE
56   INTERFACE glob_max
57      MODULE PROCEDURE glob_max_2d_sp, glob_max_3d_sp
58      MODULE PROCEDURE glob_max_2d_dp, glob_max_3d_dp
59   END INTERFACE
60
61#if defined key_nosignedzero
62   INTERFACE SIGN
63      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
64         &             SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,          &
65         &             SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B
66   END INTERFACE
67#endif
68
69   !! * Substitutions
70#  include "do_loop_substitute.h90"
71   !!----------------------------------------------------------------------
72   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
73   !! $Id$
74   !! Software governed by the CeCILL license (see ./LICENSE)
75   !!----------------------------------------------------------------------
76CONTAINS
77
78
79!                          ! FUNCTION global_sum !
80!                          ! single precision version !
81# define PRECISION sp
82# include "lib_fortran_globsum.h90"
83# undef PRECISION
84!                          ! double precision version !
85# define PRECISION dp
86# include "lib_fortran_globsum.h90"
87# undef PRECISION
88
89!                          ! FUNCTION local_sum !
90
91   FUNCTION local_sum_2d( ptab )
92      !!----------------------------------------------------------------------
93      REAL(wp),  INTENT(in   ) ::   ptab(:,:) ! array on which operation is applied
94      COMPLEX(dp)              ::  local_sum_2d
95      !
96      !!-----------------------------------------------------------------------
97      !
98      COMPLEX(dp)::   ctmp
99      REAL(wp)   ::   ztmp
100      INTEGER    ::   ji, jj    ! dummy loop indices
101      INTEGER    ::   ipi, ipj  ! dimensions
102      !!-----------------------------------------------------------------------
103      !
104      ipi = SIZE(ptab,1)   ! 1st dimension
105      ipj = SIZE(ptab,2)   ! 2nd dimension
106      !
107      ctmp = CMPLX( 0.e0, 0.e0, wp )   ! warning ctmp is cumulated
108
109      DO jj = 1, ipj
110         DO ji = 1, ipi
111            ztmp =  ptab(ji,jj) * tmask_i(ji,jj)
112            CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
113         END DO
114      END DO
115      !
116      local_sum_2d = ctmp
117       
118   END FUNCTION local_sum_2d
119
120   FUNCTION local_sum_3d( ptab )
121      !!----------------------------------------------------------------------
122      REAL(wp),  INTENT(in   ) ::   ptab(:,:,:) ! array on which operation is applied
123      COMPLEX(dp)              ::  local_sum_3d
124      !
125      !!-----------------------------------------------------------------------
126      !
127      COMPLEX(dp)::   ctmp
128      REAL(wp)   ::   ztmp
129      INTEGER    ::   ji, jj, jk   ! dummy loop indices
130      INTEGER    ::   ipi, ipj, ipk    ! dimensions
131      !!-----------------------------------------------------------------------
132      !
133      ipi = SIZE(ptab,1)   ! 1st dimension
134      ipj = SIZE(ptab,2)   ! 2nd dimension
135      ipk = SIZE(ptab,3)   ! 3rd dimension
136      !
137      ctmp = CMPLX( 0.e0, 0.e0, wp )   ! warning ctmp is cumulated
138
139      DO jk = 1, ipk
140        DO jj = 1, ipj
141          DO ji = 1, ipi
142             ztmp =  ptab(ji,jj,jk) * tmask_i(ji,jj)
143             CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
144          END DO
145        END DO
146      END DO
147      !
148      local_sum_3d = ctmp
149       
150   END FUNCTION local_sum_3d
151
152!                          ! FUNCTION sum3x3 !
153
154   SUBROUTINE sum3x3_2d( p2d )
155      !!-----------------------------------------------------------------------
156      !!                  ***  routine sum3x3_2d  ***
157      !!
158      !! ** Purpose : sum over 3x3 boxes
159      !!----------------------------------------------------------------------
160      REAL(wp), DIMENSION (:,:), INTENT(inout) ::   p2d
161      !
162      INTEGER ::   ji, ji2, jj, jj2     ! dummy loop indices
163      !!----------------------------------------------------------------------
164      !
165      IF( SIZE(p2d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the first dimension is not equal to jpi' ) 
166      IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) 
167      !
168      ! work over the whole domain (guarantees all internal cells are set when nn_hls=2)
169      !
170      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
171         IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   &              ! 1st bottom left corner always at (Nis0-1, Njs0-1)
172           & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box
173            ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
174            jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
175            IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
176               p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2))
177            ENDIF
178         ENDIF
179      END_2D
180      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
181      ! no need for 2nd exchange when nn_hls > 1
182      IF( nn_hls == 1 ) THEN
183         IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN   ! 1st column was changed during the previous call to lbc_lnk
184            IF( MOD(mig(    1), 3) == 1 )   &   ! 1st box start at i=1 -> column 1 to 3 correctly computed locally
185               p2d(    1,:) = p2d(    2,:)      ! previous lbc_lnk corrupted column 1 -> put it back using column 2
186            IF( MOD(mig(    1), 3) == 2 )   &   ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh
187               p2d(    2,:) = p2d(    1,:)      !  previous lbc_lnk fix column 1 -> copy it to column 2
188         ENDIF
189         IF( mpiRnei(nn_hls,jpea) > -1 ) THEN
190            IF( MOD(mig(jpi-2), 3) == 1 )   p2d(  jpi,:) = p2d(jpi-1,:)
191            IF( MOD(mig(jpi-2), 3) == 0 )   p2d(jpi-1,:) = p2d(  jpi,:)
192         ENDIF
193         IF( mpiRnei(nn_hls,jpso) > -1 ) THEN
194            IF( MOD(mjg(    1), 3) == 1 )   p2d(:,    1) = p2d(:,    2)
195            IF( MOD(mjg(    1), 3) == 2 )   p2d(:,    2) = p2d(:,    1)
196         ENDIF
197         IF( mpiRnei(nn_hls,jpno) > -1 ) THEN
198            IF( MOD(mjg(jpj-2), 3) == 1 )   p2d(:,  jpj) = p2d(:,jpj-1)
199            IF( MOD(mjg(jpj-2), 3) == 0 )   p2d(:,jpj-1) = p2d(:,  jpj)
200         ENDIF
201         CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
202      ENDIF
203
204   END SUBROUTINE sum3x3_2d
205
206   SUBROUTINE sum3x3_3d( p3d )
207      !!-----------------------------------------------------------------------
208      !!                  ***  routine sum3x3_3d  ***
209      !!
210      !! ** Purpose : sum over 3x3 boxes
211      !!----------------------------------------------------------------------
212      REAL(wp), DIMENSION (:,:,:), INTENT(inout) ::   p3d
213      !
214      INTEGER ::   ji, ji2, jj, jj2, jn     ! dummy loop indices
215      INTEGER ::   ipn                      ! Third dimension size
216      !!----------------------------------------------------------------------
217      !
218      IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) 
219      IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) 
220      ipn = SIZE(p3d,3)
221      !
222      DO jn = 1, ipn
223         !
224         ! work over the whole domain (guarantees all internal cells are set when nn_hls=2)
225         !
226         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
227            IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   &              ! 1st bottom left corner always at (Nis0-1, Njs0-1)
228              & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box
229               ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
230               jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
231               IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
232                  p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn))
233               ENDIF
234            ENDIF
235         END_2D
236      END DO
237      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
238      ! no need for 2nd exchange when nn_hls > 1
239      IF( nn_hls == 1 ) THEN
240         IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN    ! 1st column was changed during the previous call to lbc_lnk
241            IF( MOD(mig(    1), 3) == 1 )   &    ! 1st box start at i=1 -> column 1 to 3 correctly computed locally
242               p3d(    1,:,:) = p3d(    2,:,:)   ! previous lbc_lnk corrupted column 1 -> put it back using column 2
243            IF( MOD(mig(    1), 3) == 2 )   &    ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh
244               p3d(    2,:,:) = p3d(    1,:,:)   !  previous lbc_lnk fix column 1 -> copy it to column 2
245         ENDIF
246         IF( mpiRnei(nn_hls,jpea) > -1 ) THEN
247            IF( MOD(mig(jpi-2), 3) == 1 )   p3d(  jpi,:,:) = p3d(jpi-1,:,:)
248            IF( MOD(mig(jpi-2), 3) == 0 )   p3d(jpi-1,:,:) = p3d(  jpi,:,:)
249         ENDIF
250         IF( mpiRnei(nn_hls,jpso) > -1 ) THEN
251            IF( MOD(mjg(    1), 3) == 1 )   p3d(:,    1,:) = p3d(:,    2,:)
252            IF( MOD(mjg(    1), 3) == 2 )   p3d(:,    2,:) = p3d(:,    1,:)
253         ENDIF
254         IF( mpiRnei(nn_hls,jpno) > -1 ) THEN
255            IF( MOD(mjg(jpj-2), 3) == 1 )   p3d(:,  jpj,:) = p3d(:,jpj-1,:)
256            IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:)
257         ENDIF
258         CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
259      ENDIF
260
261   END SUBROUTINE sum3x3_3d
262
263
264   SUBROUTINE DDPDD( ydda, yddb )
265      !!----------------------------------------------------------------------
266      !!               ***  ROUTINE DDPDD ***
267      !!
268      !! ** Purpose : Add a scalar element to a sum
269      !!
270      !!
271      !! ** Method  : The code uses the compensated summation with doublet
272      !!              (sum,error) emulated useing complex numbers. ydda is the
273      !!               scalar to add to the summ yddb
274      !!
275      !! ** Action  : This does only work for MPI.
276      !!
277      !! References : Using Acurate Arithmetics to Improve Numerical
278      !!              Reproducibility and Sability in Parallel Applications
279      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
280      !!----------------------------------------------------------------------
281      COMPLEX(dp), INTENT(in   ) ::   ydda
282      COMPLEX(dp), INTENT(inout) ::   yddb
283      !
284      REAL(dp) :: zerr, zt1, zt2  ! local work variables
285      !!-----------------------------------------------------------------------
286      !
287      ! Compute ydda + yddb using Knuth's trick.
288      zt1  = REAL(ydda) + REAL(yddb)
289      zerr = zt1 - REAL(ydda)
290      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
291         &   + AIMAG(ydda)         + AIMAG(yddb)
292      !
293      ! The result is t1 + t2, after normalization.
294      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
295      !
296   END SUBROUTINE DDPDD
297
298#if defined key_nosignedzero
299   !!----------------------------------------------------------------------
300   !!   'key_nosignedzero'                                         F90 SIGN
301   !!----------------------------------------------------------------------
302
303   FUNCTION SIGN_SCALAR( pa, pb )
304      !!-----------------------------------------------------------------------
305      !!                  ***  FUNCTION SIGN_SCALAR  ***
306      !!
307      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
308      !!-----------------------------------------------------------------------
309      REAL(wp) :: pa,pb          ! input
310      REAL(wp) :: SIGN_SCALAR    ! result
311      !!-----------------------------------------------------------------------
312      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
313      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
314      ENDIF
315   END FUNCTION SIGN_SCALAR
316
317
318   FUNCTION SIGN_ARRAY_1D( pa, pb )
319      !!-----------------------------------------------------------------------
320      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
321      !!
322      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
323      !!-----------------------------------------------------------------------
324      REAL(wp) :: pa,pb(:)                   ! input
325      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
326      !!-----------------------------------------------------------------------
327      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
328      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
329      END WHERE
330   END FUNCTION SIGN_ARRAY_1D
331
332
333   FUNCTION SIGN_ARRAY_2D(pa,pb)
334      !!-----------------------------------------------------------------------
335      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
336      !!
337      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
338      !!-----------------------------------------------------------------------
339      REAL(wp) :: pa,pb(:,:)      ! input
340      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
341      !!-----------------------------------------------------------------------
342      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
343      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
344      END WHERE
345   END FUNCTION SIGN_ARRAY_2D
346
347   FUNCTION SIGN_ARRAY_3D(pa,pb)
348      !!-----------------------------------------------------------------------
349      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
350      !!
351      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
352      !!-----------------------------------------------------------------------
353      REAL(wp) :: pa,pb(:,:,:)      ! input
354      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
355      !!-----------------------------------------------------------------------
356      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
357      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
358      END WHERE
359   END FUNCTION SIGN_ARRAY_3D
360
361
362   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
363      !!-----------------------------------------------------------------------
364      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
365      !!
366      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
367      !!-----------------------------------------------------------------------
368      REAL(wp) :: pa(:),pb(:)      ! input
369      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
370      !!-----------------------------------------------------------------------
371      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
372      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
373      END WHERE
374   END FUNCTION SIGN_ARRAY_1D_A
375
376
377   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
378      !!-----------------------------------------------------------------------
379      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
380      !!
381      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
382      !!-----------------------------------------------------------------------
383      REAL(wp) :: pa(:,:),pb(:,:)      ! input
384      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
385      !!-----------------------------------------------------------------------
386      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
387      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
388      END WHERE
389   END FUNCTION SIGN_ARRAY_2D_A
390
391
392   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
393      !!-----------------------------------------------------------------------
394      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
395      !!
396      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
397      !!-----------------------------------------------------------------------
398      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
399      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
400      !!-----------------------------------------------------------------------
401      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
402      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
403      END WHERE
404   END FUNCTION SIGN_ARRAY_3D_A
405
406
407   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
408      !!-----------------------------------------------------------------------
409      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
410      !!
411      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
412      !!-----------------------------------------------------------------------
413      REAL(wp) :: pa(:),pb      ! input
414      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
415      !!-----------------------------------------------------------------------
416      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
417      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
418      ENDIF
419   END FUNCTION SIGN_ARRAY_1D_B
420
421
422   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
423      !!-----------------------------------------------------------------------
424      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
425      !!
426      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
427      !!-----------------------------------------------------------------------
428      REAL(wp) :: pa(:,:),pb      ! input
429      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
430      !!-----------------------------------------------------------------------
431      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
432      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
433      ENDIF
434   END FUNCTION SIGN_ARRAY_2D_B
435
436
437   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
438      !!-----------------------------------------------------------------------
439      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
440      !!
441      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
442      !!-----------------------------------------------------------------------
443      REAL(wp) :: pa(:,:,:),pb      ! input
444      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
445      !!-----------------------------------------------------------------------
446      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
447      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
448      ENDIF
449   END FUNCTION SIGN_ARRAY_3D_B
450#endif
451
452   !!======================================================================
453END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.