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/2019/ENHANCE-02_ISF_nemo/src/OCE – NEMO

source: NEMO/branches/2019/ENHANCE-02_ISF_nemo/src/OCE/lib_fortran.F90 @ 11823

Last change on this file since 11823 was 10425, checked in by smasson, 5 years ago

trunk: merge back dev_r10164_HPC09_ESIWACE_PREP_MERGE@10424 into the trunk

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