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

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

Last change on this file since 14433 was 14433, checked in by smasson, 3 years ago

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