New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lib_fortran.F90 in NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE – NEMO

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

Last change on this file since 14219 was 14219, checked in by mcastril, 4 years ago

Add Mixed Precision support by Oriol Tintó
  • Property svn:keywords set to Id
File size: 23.2 KB
Line 
1MODULE lib_fortran
2   !!======================================================================
3   !!                       ***  MODULE  lib_fortran  ***
4   !! Fortran utilities:  includes some low levels fortran functionality
5   !!======================================================================
6   !! History :  3.2  !  2010-05  (M. Dunphy, R. Benshila)  Original code
7   !!            3.4  !  2013-06  (C. Rousset)  add glob_min, glob_max
8   !!                                           + 3d dim. of input is fexible (jpk, jpl...)
9   !!            4.0  !  2016-06  (T. Lovato)  double precision global sum by default
10   !!----------------------------------------------------------------------
11
12   !!----------------------------------------------------------------------
13   !!   glob_sum    : generic interface for global masked summation over
14   !!                 the interior domain for 1 or 2 2D or 3D arrays
15   !!                 it works only for T points
16   !!   SIGN        : generic interface for SIGN to overwrite f95 behaviour
17   !!                 of intrinsinc sign function
18   !!----------------------------------------------------------------------
19   USE par_oce         ! Ocean parameter
20   USE dom_oce         ! ocean domain
21   USE in_out_manager  ! I/O manager
22   USE lib_mpp         ! distributed memory computing
23   USE lbclnk          ! ocean lateral boundary conditions
24
25   IMPLICIT NONE
26   PRIVATE
27
28   PUBLIC   glob_sum      ! used in many places (masked with tmask_i)
29   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos)
30   PUBLIC   local_sum     ! used in trcrad, local operation before glob_sum_delay
31   PUBLIC   sum3x3        ! used in trcrad, do a sum over 3x3 boxes
32   PUBLIC   DDPDD         ! also used in closea module
33   PUBLIC   glob_min, glob_max
34#if defined key_nosignedzero
35   PUBLIC SIGN
36#endif
37
38   INTERFACE glob_sum
39      MODULE PROCEDURE glob_sum_1d_sp, glob_sum_2d_sp, glob_sum_3d_sp
40      MODULE PROCEDURE glob_sum_1d_dp, glob_sum_2d_dp, glob_sum_3d_dp
41   END INTERFACE
42   INTERFACE glob_sum_full
43      MODULE PROCEDURE glob_sum_full_2d_sp, glob_sum_full_3d_sp
44      MODULE PROCEDURE glob_sum_full_2d_dp, glob_sum_full_3d_dp
45   END INTERFACE
46   INTERFACE local_sum
47      MODULE PROCEDURE local_sum_2d, local_sum_3d
48   END INTERFACE
49   INTERFACE sum3x3
50      MODULE PROCEDURE sum3x3_2d, sum3x3_3d
51   END INTERFACE
52   INTERFACE glob_min
53      MODULE PROCEDURE glob_min_2d_sp, glob_min_3d_sp
54      MODULE PROCEDURE glob_min_2d_dp, glob_min_3d_dp
55   END INTERFACE
56   INTERFACE glob_max
57      MODULE PROCEDURE glob_max_2d_sp, glob_max_3d_sp
58      MODULE PROCEDURE glob_max_2d_dp, glob_max_3d_dp
59   END INTERFACE
60
61#if defined key_nosignedzero
62   INTERFACE SIGN
63      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
64         &             SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,          &
65         &             SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B
66   END INTERFACE
67#endif
68
69   !! * Substitutions
70#  include "do_loop_substitute.h90"
71   !!----------------------------------------------------------------------
72   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
73   !! $Id$
74   !! Software governed by the CeCILL license (see ./LICENSE)
75   !!----------------------------------------------------------------------
76CONTAINS
77
78#  define GLOBSUM_CODE
79
80#     define SINGLE_PRECISION
81#        define DIM_1d
82#        define FUNCTION_GLOBSUM           glob_sum_1d_sp
83#        include "lib_fortran_generic.h90"
84#        undef FUNCTION_GLOBSUM
85#        undef DIM_1d
86
87#        define DIM_2d
88#        define OPERATION_GLOBSUM
89#        define FUNCTION_GLOBSUM           glob_sum_2d_sp
90#        include "lib_fortran_generic.h90"
91#        undef FUNCTION_GLOBSUM
92#        undef OPERATION_GLOBSUM
93#        define OPERATION_FULL_GLOBSUM
94#        define FUNCTION_GLOBSUM           glob_sum_full_2d_sp
95#        include "lib_fortran_generic.h90"
96#        undef FUNCTION_GLOBSUM
97#        undef OPERATION_FULL_GLOBSUM
98#        undef DIM_2d
99
100#        define DIM_3d
101#        define OPERATION_GLOBSUM
102#        define FUNCTION_GLOBSUM           glob_sum_3d_sp
103#        include "lib_fortran_generic.h90"
104#        undef FUNCTION_GLOBSUM
105#        undef OPERATION_GLOBSUM
106#        define OPERATION_FULL_GLOBSUM
107#        define FUNCTION_GLOBSUM           glob_sum_full_3d_sp
108#        include "lib_fortran_generic.h90"
109#        undef FUNCTION_GLOBSUM
110#        undef OPERATION_FULL_GLOBSUM
111#        undef DIM_3d
112#     undef SINGLE_PRECISION
113! Double Precision versions
114#        define DIM_1d
115#        define FUNCTION_GLOBSUM           glob_sum_1d_dp
116#        include "lib_fortran_generic.h90"
117#        undef FUNCTION_GLOBSUM
118#        undef DIM_1d
119
120#        define DIM_2d
121#        define OPERATION_GLOBSUM
122#        define FUNCTION_GLOBSUM           glob_sum_2d_dp
123#        include "lib_fortran_generic.h90"
124#        undef FUNCTION_GLOBSUM
125#        undef OPERATION_GLOBSUM
126#        define OPERATION_FULL_GLOBSUM
127#        define FUNCTION_GLOBSUM           glob_sum_full_2d_dp
128#        include "lib_fortran_generic.h90"
129#        undef FUNCTION_GLOBSUM
130#        undef OPERATION_FULL_GLOBSUM
131#        undef DIM_2d
132
133#        define DIM_3d
134#        define OPERATION_GLOBSUM
135#        define FUNCTION_GLOBSUM           glob_sum_3d_dp
136#        include "lib_fortran_generic.h90"
137#        undef FUNCTION_GLOBSUM
138#        undef OPERATION_GLOBSUM
139#        define OPERATION_FULL_GLOBSUM
140#        define FUNCTION_GLOBSUM           glob_sum_full_3d_dp
141#        include "lib_fortran_generic.h90"
142#        undef FUNCTION_GLOBSUM
143#        undef OPERATION_FULL_GLOBSUM
144#        undef DIM_3d
145
146#  undef GLOBSUM_CODE
147
148! Single Precision versions
149#  define GLOBMINMAX_CODE
150
151#     define SINGLE_PRECISION
152#        define DIM_2d
153#        define OPERATION_GLOBMIN
154#        define FUNCTION_GLOBMINMAX           glob_min_2d_sp
155#        include "lib_fortran_generic.h90"
156#        undef FUNCTION_GLOBMINMAX
157#        undef OPERATION_GLOBMIN
158#        define OPERATION_GLOBMAX
159#        define FUNCTION_GLOBMINMAX           glob_max_2d_sp
160#        include "lib_fortran_generic.h90"
161#        undef FUNCTION_GLOBMINMAX
162#        undef OPERATION_GLOBMAX
163#        undef DIM_2d
164
165#        define DIM_3d
166#        define OPERATION_GLOBMIN
167#        define FUNCTION_GLOBMINMAX           glob_min_3d_sp
168#        include "lib_fortran_generic.h90"
169#        undef FUNCTION_GLOBMINMAX
170#        undef OPERATION_GLOBMIN
171#        define OPERATION_GLOBMAX
172#        define FUNCTION_GLOBMINMAX           glob_max_3d_sp
173#        include "lib_fortran_generic.h90"
174#        undef FUNCTION_GLOBMINMAX
175#        undef OPERATION_GLOBMAX
176#        undef DIM_3d
177#     undef SINGLE_PRECISION
178! Double Precision versions
179#        define DIM_2d
180#        define OPERATION_GLOBMIN
181#        define FUNCTION_GLOBMINMAX           glob_min_2d_dp
182#        include "lib_fortran_generic.h90"
183#        undef FUNCTION_GLOBMINMAX
184#        undef OPERATION_GLOBMIN
185#        define OPERATION_GLOBMAX
186#        define FUNCTION_GLOBMINMAX           glob_max_2d_dp
187#        include "lib_fortran_generic.h90"
188#        undef FUNCTION_GLOBMINMAX
189#        undef OPERATION_GLOBMAX
190#        undef DIM_2d
191
192#        define DIM_3d
193#        define OPERATION_GLOBMIN
194#        define FUNCTION_GLOBMINMAX           glob_min_3d_dp
195#        include "lib_fortran_generic.h90"
196#        undef FUNCTION_GLOBMINMAX
197#        undef OPERATION_GLOBMIN
198#        define OPERATION_GLOBMAX
199#        define FUNCTION_GLOBMINMAX           glob_max_3d_dp
200#        include "lib_fortran_generic.h90"
201#        undef FUNCTION_GLOBMINMAX
202#        undef OPERATION_GLOBMAX
203#        undef DIM_3d
204#  undef GLOBMINMAX_CODE
205
206!                          ! FUNCTION local_sum !
207
208   FUNCTION local_sum_2d( ptab )
209      !!----------------------------------------------------------------------
210      REAL(wp),  INTENT(in   ) ::   ptab(:,:) ! array on which operation is applied
211      COMPLEX(dp)              ::  local_sum_2d
212      !
213      !!-----------------------------------------------------------------------
214      !
215      COMPLEX(dp)::   ctmp
216      REAL(wp)   ::   ztmp
217      INTEGER    ::   ji, jj    ! dummy loop indices
218      INTEGER    ::   ipi, ipj  ! dimensions
219      !!-----------------------------------------------------------------------
220      !
221      ipi = SIZE(ptab,1)   ! 1st dimension
222      ipj = SIZE(ptab,2)   ! 2nd dimension
223      !
224      ctmp = CMPLX( 0.e0, 0.e0, wp )   ! warning ctmp is cumulated
225
226      DO jj = 1, ipj
227         DO ji = 1, ipi
228            ztmp =  ptab(ji,jj) * tmask_i(ji,jj)
229            CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
230         END DO
231      END DO
232      !
233      local_sum_2d = ctmp
234       
235   END FUNCTION local_sum_2d
236
237   FUNCTION local_sum_3d( ptab )
238      !!----------------------------------------------------------------------
239      REAL(wp),  INTENT(in   ) ::   ptab(:,:,:) ! array on which operation is applied
240      COMPLEX(dp)              ::  local_sum_3d
241      !
242      !!-----------------------------------------------------------------------
243      !
244      COMPLEX(dp)::   ctmp
245      REAL(wp)   ::   ztmp
246      INTEGER    ::   ji, jj, jk   ! dummy loop indices
247      INTEGER    ::   ipi, ipj, ipk    ! dimensions
248      !!-----------------------------------------------------------------------
249      !
250      ipi = SIZE(ptab,1)   ! 1st dimension
251      ipj = SIZE(ptab,2)   ! 2nd dimension
252      ipk = SIZE(ptab,3)   ! 3rd dimension
253      !
254      ctmp = CMPLX( 0.e0, 0.e0, wp )   ! warning ctmp is cumulated
255
256      DO jk = 1, ipk
257        DO jj = 1, ipj
258          DO ji = 1, ipi
259             ztmp =  ptab(ji,jj,jk) * tmask_i(ji,jj)
260             CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
261          END DO
262        END DO
263      END DO
264      !
265      local_sum_3d = ctmp
266       
267   END FUNCTION local_sum_3d
268
269!                          ! FUNCTION sum3x3 !
270
271   SUBROUTINE sum3x3_2d( p2d )
272      !!-----------------------------------------------------------------------
273      !!                  ***  routine sum3x3_2d  ***
274      !!
275      !! ** Purpose : sum over 3x3 boxes
276      !!----------------------------------------------------------------------
277      REAL(wp), DIMENSION (:,:), INTENT(inout) ::   p2d
278      !
279      INTEGER ::   ji, ji2, jj, jj2     ! dummy loop indices
280      !!----------------------------------------------------------------------
281      !
282      IF( SIZE(p2d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the first dimension is not equal to jpi' ) 
283      IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) 
284      !
285      ! work over the whole domain (guarantees all internal cells are set when nn_hls=2)
286      !
287      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
288         IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   &
289           & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box
290            ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
291            jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
292            IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
293               p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2))
294            ENDIF
295         ENDIF
296      END_2D
297      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
298      ! no need for 2nd exchange when nn_hls = 2
299      IF( nn_hls /= 2 ) THEN
300         IF( nbondi /= -1 ) THEN
301            IF( MOD(mig(    1), 3) == 1 )   p2d(    1,:) = p2d(    2,:)
302            IF( MOD(mig(    1), 3) == 2 )   p2d(    2,:) = p2d(    1,:)
303         ENDIF
304         IF( nbondi /=  1 ) THEN
305            IF( MOD(mig(jpi-2), 3) == 1 )   p2d(  jpi,:) = p2d(jpi-1,:)
306            IF( MOD(mig(jpi-2), 3) == 0 )   p2d(jpi-1,:) = p2d(  jpi,:)
307         ENDIF
308         IF( nbondj /= -1 ) THEN
309            IF( MOD(mjg(    1), 3) == 1 )   p2d(:,    1) = p2d(:,    2)
310            IF( MOD(mjg(    1), 3) == 2 )   p2d(:,    2) = p2d(:,    1)
311         ENDIF
312         IF( nbondj /=  1 ) THEN
313            IF( MOD(mjg(jpj-2), 3) == 1 )   p2d(:,  jpj) = p2d(:,jpj-1)
314            IF( MOD(mjg(jpj-2), 3) == 0 )   p2d(:,jpj-1) = p2d(:,  jpj)
315         ENDIF
316         CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
317      ENDIF
318
319   END SUBROUTINE sum3x3_2d
320
321   SUBROUTINE sum3x3_3d( p3d )
322      !!-----------------------------------------------------------------------
323      !!                  ***  routine sum3x3_3d  ***
324      !!
325      !! ** Purpose : sum over 3x3 boxes
326      !!----------------------------------------------------------------------
327      REAL(wp), DIMENSION (:,:,:), INTENT(inout) ::   p3d
328      !
329      INTEGER ::   ji, ji2, jj, jj2, jn     ! dummy loop indices
330      INTEGER ::   ipn                      ! Third dimension size
331      !!----------------------------------------------------------------------
332      !
333      IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) 
334      IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) 
335      ipn = SIZE(p3d,3)
336      !
337      DO jn = 1, ipn
338         !
339         ! work over the whole domain (guarantees all internal cells are set when nn_hls=2)
340         !
341         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
342            IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   &
343              & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box
344               ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
345               jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
346               IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
347                  p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn))
348               ENDIF
349            ENDIF
350         END_2D
351      END DO
352      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
353      ! no need for 2nd exchange when nn_hls = 2
354      IF( nn_hls /= 2 ) THEN
355         IF( nbondi /= -1 ) THEN
356            IF( MOD(mig(    1), 3) == 1 )   p3d(    1,:,:) = p3d(    2,:,:)
357            IF( MOD(mig(    1), 3) == 2 )   p3d(    2,:,:) = p3d(    1,:,:)
358         ENDIF
359         IF( nbondi /=  1 ) THEN
360            IF( MOD(mig(jpi-2), 3) == 1 )   p3d(  jpi,:,:) = p3d(jpi-1,:,:)
361            IF( MOD(mig(jpi-2), 3) == 0 )   p3d(jpi-1,:,:) = p3d(  jpi,:,:)
362         ENDIF
363         IF( nbondj /= -1 ) THEN
364            IF( MOD(mjg(    1), 3) == 1 )   p3d(:,    1,:) = p3d(:,    2,:)
365            IF( MOD(mjg(    1), 3) == 2 )   p3d(:,    2,:) = p3d(:,    1,:)
366         ENDIF
367         IF( nbondj /=  1 ) THEN
368            IF( MOD(mjg(jpj-2), 3) == 1 )   p3d(:,  jpj,:) = p3d(:,jpj-1,:)
369            IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:)
370         ENDIF
371         CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
372      ENDIF
373
374   END SUBROUTINE sum3x3_3d
375
376
377   SUBROUTINE DDPDD( ydda, yddb )
378      !!----------------------------------------------------------------------
379      !!               ***  ROUTINE DDPDD ***
380      !!
381      !! ** Purpose : Add a scalar element to a sum
382      !!
383      !!
384      !! ** Method  : The code uses the compensated summation with doublet
385      !!              (sum,error) emulated useing complex numbers. ydda is the
386      !!               scalar to add to the summ yddb
387      !!
388      !! ** Action  : This does only work for MPI.
389      !!
390      !! References : Using Acurate Arithmetics to Improve Numerical
391      !!              Reproducibility and Sability in Parallel Applications
392      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
393      !!----------------------------------------------------------------------
394      COMPLEX(dp), INTENT(in   ) ::   ydda
395      COMPLEX(dp), INTENT(inout) ::   yddb
396      !
397      REAL(dp) :: zerr, zt1, zt2  ! local work variables
398      !!-----------------------------------------------------------------------
399      !
400      ! Compute ydda + yddb using Knuth's trick.
401      zt1  = REAL(ydda) + REAL(yddb)
402      zerr = zt1 - REAL(ydda)
403      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
404         &   + AIMAG(ydda)         + AIMAG(yddb)
405      !
406      ! The result is t1 + t2, after normalization.
407      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
408      !
409   END SUBROUTINE DDPDD
410
411#if defined key_nosignedzero
412   !!----------------------------------------------------------------------
413   !!   'key_nosignedzero'                                         F90 SIGN
414   !!----------------------------------------------------------------------
415
416   FUNCTION SIGN_SCALAR( pa, pb )
417      !!-----------------------------------------------------------------------
418      !!                  ***  FUNCTION SIGN_SCALAR  ***
419      !!
420      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
421      !!-----------------------------------------------------------------------
422      REAL(wp) :: pa,pb          ! input
423      REAL(wp) :: SIGN_SCALAR    ! result
424      !!-----------------------------------------------------------------------
425      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
426      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
427      ENDIF
428   END FUNCTION SIGN_SCALAR
429
430
431   FUNCTION SIGN_ARRAY_1D( pa, pb )
432      !!-----------------------------------------------------------------------
433      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
434      !!
435      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
436      !!-----------------------------------------------------------------------
437      REAL(wp) :: pa,pb(:)                   ! input
438      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
439      !!-----------------------------------------------------------------------
440      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
441      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
442      END WHERE
443   END FUNCTION SIGN_ARRAY_1D
444
445
446   FUNCTION SIGN_ARRAY_2D(pa,pb)
447      !!-----------------------------------------------------------------------
448      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
449      !!
450      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
451      !!-----------------------------------------------------------------------
452      REAL(wp) :: pa,pb(:,:)      ! input
453      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
454      !!-----------------------------------------------------------------------
455      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
456      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
457      END WHERE
458   END FUNCTION SIGN_ARRAY_2D
459
460   FUNCTION SIGN_ARRAY_3D(pa,pb)
461      !!-----------------------------------------------------------------------
462      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
463      !!
464      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
465      !!-----------------------------------------------------------------------
466      REAL(wp) :: pa,pb(:,:,:)      ! input
467      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
468      !!-----------------------------------------------------------------------
469      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
470      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
471      END WHERE
472   END FUNCTION SIGN_ARRAY_3D
473
474
475   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
476      !!-----------------------------------------------------------------------
477      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
478      !!
479      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
480      !!-----------------------------------------------------------------------
481      REAL(wp) :: pa(:),pb(:)      ! input
482      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
483      !!-----------------------------------------------------------------------
484      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
485      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
486      END WHERE
487   END FUNCTION SIGN_ARRAY_1D_A
488
489
490   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
491      !!-----------------------------------------------------------------------
492      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
493      !!
494      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
495      !!-----------------------------------------------------------------------
496      REAL(wp) :: pa(:,:),pb(:,:)      ! input
497      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
498      !!-----------------------------------------------------------------------
499      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
500      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
501      END WHERE
502   END FUNCTION SIGN_ARRAY_2D_A
503
504
505   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
506      !!-----------------------------------------------------------------------
507      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
508      !!
509      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
510      !!-----------------------------------------------------------------------
511      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
512      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
513      !!-----------------------------------------------------------------------
514      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
515      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
516      END WHERE
517   END FUNCTION SIGN_ARRAY_3D_A
518
519
520   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
521      !!-----------------------------------------------------------------------
522      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
523      !!
524      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
525      !!-----------------------------------------------------------------------
526      REAL(wp) :: pa(:),pb      ! input
527      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
528      !!-----------------------------------------------------------------------
529      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
530      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
531      ENDIF
532   END FUNCTION SIGN_ARRAY_1D_B
533
534
535   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
536      !!-----------------------------------------------------------------------
537      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
538      !!
539      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
540      !!-----------------------------------------------------------------------
541      REAL(wp) :: pa(:,:),pb      ! input
542      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
543      !!-----------------------------------------------------------------------
544      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
545      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
546      ENDIF
547   END FUNCTION SIGN_ARRAY_2D_B
548
549
550   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
551      !!-----------------------------------------------------------------------
552      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
553      !!
554      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
555      !!-----------------------------------------------------------------------
556      REAL(wp) :: pa(:,:,:),pb      ! input
557      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
558      !!-----------------------------------------------------------------------
559      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
560      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
561      ENDIF
562   END FUNCTION SIGN_ARRAY_3D_B
563#endif
564
565   !!======================================================================
566END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.