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

source: NEMO/branches/2020/ticket2487/src/OCE/lib_fortran.F90 @ 15410

Last change on this file since 15410 was 15410, checked in by smueller, 3 years ago

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