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/r12377_ticket2386/src/OCE – NEMO

source: NEMO/branches/2020/r12377_ticket2386/src/OCE/lib_fortran.F90 @ 13540

Last change on this file since 13540 was 13540, checked in by andmirek, 3 years ago

Ticket #2386: update to latest trunk

  • Property svn:keywords set to Id
File size: 20.6 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) == MOD(nn_hls, 3) .AND.   &
223           & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box
224            ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
225            jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
226            IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
227               p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2))
228            ENDIF
229         ENDIF
230      END_2D
231      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
232      ! no need for 2nd exchange when nn_hls = 2
233      IF( nn_hls /= 2 ) THEN
234         IF( nbondi /= -1 ) THEN
235            IF( MOD(mig(    1), 3) == 1 )   p2d(    1,:) = p2d(    2,:)
236            IF( MOD(mig(    1), 3) == 2 )   p2d(    2,:) = p2d(    1,:)
237         ENDIF
238         IF( nbondi /=  1 ) THEN
239            IF( MOD(mig(jpi-2), 3) == 1 )   p2d(  jpi,:) = p2d(jpi-1,:)
240            IF( MOD(mig(jpi-2), 3) == 0 )   p2d(jpi-1,:) = p2d(  jpi,:)
241         ENDIF
242         IF( nbondj /= -1 ) THEN
243            IF( MOD(mjg(    1), 3) == 1 )   p2d(:,    1) = p2d(:,    2)
244            IF( MOD(mjg(    1), 3) == 2 )   p2d(:,    2) = p2d(:,    1)
245         ENDIF
246         IF( nbondj /=  1 ) THEN
247            IF( MOD(mjg(jpj-2), 3) == 1 )   p2d(:,  jpj) = p2d(:,jpj-1)
248            IF( MOD(mjg(jpj-2), 3) == 0 )   p2d(:,jpj-1) = p2d(:,  jpj)
249         ENDIF
250         CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
251      ENDIF
252
253   END SUBROUTINE sum3x3_2d
254
255   SUBROUTINE sum3x3_3d( p3d )
256      !!-----------------------------------------------------------------------
257      !!                  ***  routine sum3x3_3d  ***
258      !!
259      !! ** Purpose : sum over 3x3 boxes
260      !!----------------------------------------------------------------------
261      REAL(wp), DIMENSION (:,:,:), INTENT(inout) ::   p3d
262      !
263      INTEGER ::   ji, ji2, jj, jj2, jn     ! dummy loop indices
264      INTEGER ::   ipn                      ! Third dimension size
265      !!----------------------------------------------------------------------
266      !
267      IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) 
268      IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) 
269      ipn = SIZE(p3d,3)
270      !
271      DO jn = 1, ipn
272         !
273         ! work over the whole domain (guarantees all internal cells are set when nn_hls=2)
274         !
275         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
276            IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   &
277              & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box
278               ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
279               jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
280               IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
281                  p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn))
282               ENDIF
283            ENDIF
284         END_2D
285      END DO
286      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
287      ! no need for 2nd exchange when nn_hls = 2
288      IF( nn_hls /= 2 ) THEN
289         IF( nbondi /= -1 ) THEN
290            IF( MOD(mig(    1), 3) == 1 )   p3d(    1,:,:) = p3d(    2,:,:)
291            IF( MOD(mig(    1), 3) == 2 )   p3d(    2,:,:) = p3d(    1,:,:)
292         ENDIF
293         IF( nbondi /=  1 ) THEN
294            IF( MOD(mig(jpi-2), 3) == 1 )   p3d(  jpi,:,:) = p3d(jpi-1,:,:)
295            IF( MOD(mig(jpi-2), 3) == 0 )   p3d(jpi-1,:,:) = p3d(  jpi,:,:)
296         ENDIF
297         IF( nbondj /= -1 ) THEN
298            IF( MOD(mjg(    1), 3) == 1 )   p3d(:,    1,:) = p3d(:,    2,:)
299            IF( MOD(mjg(    1), 3) == 2 )   p3d(:,    2,:) = p3d(:,    1,:)
300         ENDIF
301         IF( nbondj /=  1 ) THEN
302            IF( MOD(mjg(jpj-2), 3) == 1 )   p3d(:,  jpj,:) = p3d(:,jpj-1,:)
303            IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:)
304         ENDIF
305         CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
306      ENDIF
307
308   END SUBROUTINE sum3x3_3d
309
310
311   SUBROUTINE DDPDD( ydda, yddb )
312      !!----------------------------------------------------------------------
313      !!               ***  ROUTINE DDPDD ***
314      !!
315      !! ** Purpose : Add a scalar element to a sum
316      !!
317      !!
318      !! ** Method  : The code uses the compensated summation with doublet
319      !!              (sum,error) emulated useing complex numbers. ydda is the
320      !!               scalar to add to the summ yddb
321      !!
322      !! ** Action  : This does only work for MPI.
323      !!
324      !! References : Using Acurate Arithmetics to Improve Numerical
325      !!              Reproducibility and Sability in Parallel Applications
326      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
327      !!----------------------------------------------------------------------
328      COMPLEX(dp), INTENT(in   ) ::   ydda
329      COMPLEX(dp), INTENT(inout) ::   yddb
330      !
331      REAL(dp) :: zerr, zt1, zt2  ! local work variables
332      !!-----------------------------------------------------------------------
333      !
334      ! Compute ydda + yddb using Knuth's trick.
335      zt1  = REAL(ydda) + REAL(yddb)
336      zerr = zt1 - REAL(ydda)
337      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
338         &   + AIMAG(ydda)         + AIMAG(yddb)
339      !
340      ! The result is t1 + t2, after normalization.
341      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
342      !
343   END SUBROUTINE DDPDD
344
345#if defined key_nosignedzero
346   !!----------------------------------------------------------------------
347   !!   'key_nosignedzero'                                         F90 SIGN
348   !!----------------------------------------------------------------------
349
350   FUNCTION SIGN_SCALAR( pa, pb )
351      !!-----------------------------------------------------------------------
352      !!                  ***  FUNCTION SIGN_SCALAR  ***
353      !!
354      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
355      !!-----------------------------------------------------------------------
356      REAL(wp) :: pa,pb          ! input
357      REAL(wp) :: SIGN_SCALAR    ! result
358      !!-----------------------------------------------------------------------
359      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
360      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
361      ENDIF
362   END FUNCTION SIGN_SCALAR
363
364
365   FUNCTION SIGN_ARRAY_1D( pa, pb )
366      !!-----------------------------------------------------------------------
367      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
368      !!
369      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
370      !!-----------------------------------------------------------------------
371      REAL(wp) :: pa,pb(:)                   ! input
372      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
373      !!-----------------------------------------------------------------------
374      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
375      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
376      END WHERE
377   END FUNCTION SIGN_ARRAY_1D
378
379
380   FUNCTION SIGN_ARRAY_2D(pa,pb)
381      !!-----------------------------------------------------------------------
382      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
383      !!
384      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
385      !!-----------------------------------------------------------------------
386      REAL(wp) :: pa,pb(:,:)      ! input
387      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
388      !!-----------------------------------------------------------------------
389      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
390      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
391      END WHERE
392   END FUNCTION SIGN_ARRAY_2D
393
394   FUNCTION SIGN_ARRAY_3D(pa,pb)
395      !!-----------------------------------------------------------------------
396      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
397      !!
398      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
399      !!-----------------------------------------------------------------------
400      REAL(wp) :: pa,pb(:,:,:)      ! input
401      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
402      !!-----------------------------------------------------------------------
403      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
404      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
405      END WHERE
406   END FUNCTION SIGN_ARRAY_3D
407
408
409   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
410      !!-----------------------------------------------------------------------
411      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
412      !!
413      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
414      !!-----------------------------------------------------------------------
415      REAL(wp) :: pa(:),pb(:)      ! input
416      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
417      !!-----------------------------------------------------------------------
418      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
419      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
420      END WHERE
421   END FUNCTION SIGN_ARRAY_1D_A
422
423
424   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
425      !!-----------------------------------------------------------------------
426      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
427      !!
428      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
429      !!-----------------------------------------------------------------------
430      REAL(wp) :: pa(:,:),pb(:,:)      ! input
431      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
432      !!-----------------------------------------------------------------------
433      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
434      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
435      END WHERE
436   END FUNCTION SIGN_ARRAY_2D_A
437
438
439   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
440      !!-----------------------------------------------------------------------
441      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
442      !!
443      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
444      !!-----------------------------------------------------------------------
445      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
446      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
447      !!-----------------------------------------------------------------------
448      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
449      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
450      END WHERE
451   END FUNCTION SIGN_ARRAY_3D_A
452
453
454   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
455      !!-----------------------------------------------------------------------
456      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
457      !!
458      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
459      !!-----------------------------------------------------------------------
460      REAL(wp) :: pa(:),pb      ! input
461      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
462      !!-----------------------------------------------------------------------
463      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
464      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
465      ENDIF
466   END FUNCTION SIGN_ARRAY_1D_B
467
468
469   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
470      !!-----------------------------------------------------------------------
471      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
472      !!
473      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
474      !!-----------------------------------------------------------------------
475      REAL(wp) :: pa(:,:),pb      ! input
476      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
477      !!-----------------------------------------------------------------------
478      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
479      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
480      ENDIF
481   END FUNCTION SIGN_ARRAY_2D_B
482
483
484   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
485      !!-----------------------------------------------------------------------
486      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
487      !!
488      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
489      !!-----------------------------------------------------------------------
490      REAL(wp) :: pa(:,:,:),pb      ! input
491      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
492      !!-----------------------------------------------------------------------
493      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
494      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
495      ENDIF
496   END FUNCTION SIGN_ARRAY_3D_B
497#endif
498
499   !!======================================================================
500END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.