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_r12377_KERNEL-06_techene_e3/src/OCE – NEMO

source: NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/lib_fortran.F90 @ 12779

Last change on this file since 12779 was 12377, checked in by acc, 4 years ago

The big one. Merging all 2019 developments from the option 1 branch back onto the trunk.

This changeset reproduces 2019/dev_r11943_MERGE_2019 on the trunk using a 2-URL merge
onto a working copy of the trunk. I.e.:

svn merge --ignore-ancestry \

svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/trunk \
svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/branches/2019/dev_r11943_MERGE_2019 ./

The --ignore-ancestry flag avoids problems that may otherwise arise from the fact that
the merge history been trunk and branch may have been applied in a different order but
care has been taken before this step to ensure that all applicable fixes and updates
are present in the merge branch.

The trunk state just before this step has been branched to releases/release-4.0-HEAD
and that branch has been immediately tagged as releases/release-4.0.2. Any fixes
or additions in response to tickets on 4.0, 4.0.1 or 4.0.2 should be done on
releases/release-4.0-HEAD. From now on future 'point' releases (e.g. 4.0.2) will
remain unchanged with periodic releases as needs demand. Note release-4.0-HEAD is a
transitional naming convention. Future full releases, say 4.2, will have a release-4.2
branch which fulfills this role and the first point release (e.g. 4.2.0) will be made
immediately following the release branch creation.

2020 developments can be started from any trunk revision later than this one.

  • Property svn:keywords set to Id
File size: 20.0 KB
Line 
1MODULE lib_fortran
2   !!======================================================================
3   !!                       ***  MODULE  lib_fortran  ***
4   !! Fortran utilities:  includes some low levels fortran functionality
5   !!======================================================================
6   !! History :  3.2  !  2010-05  (M. Dunphy, R. Benshila)  Original code
7   !!            3.4  !  2013-06  (C. Rousset)  add glob_min, glob_max
8   !!                                           + 3d dim. of input is fexible (jpk, jpl...)
9   !!            4.0  !  2016-06  (T. Lovato)  double precision global sum by default
10   !!----------------------------------------------------------------------
11
12   !!----------------------------------------------------------------------
13   !!   glob_sum    : generic interface for global masked summation over
14   !!                 the interior domain for 1 or 2 2D or 3D arrays
15   !!                 it works only for T points
16   !!   SIGN        : generic interface for SIGN to overwrite f95 behaviour
17   !!                 of intrinsinc sign function
18   !!----------------------------------------------------------------------
19   USE par_oce         ! Ocean parameter
20   USE dom_oce         ! ocean domain
21   USE in_out_manager  ! I/O manager
22   USE lib_mpp         ! distributed memory computing
23   USE lbclnk          ! ocean lateral boundary conditions
24
25   IMPLICIT NONE
26   PRIVATE
27
28   PUBLIC   glob_sum      ! used in many places (masked with tmask_i)
29   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos)
30   PUBLIC   local_sum     ! used in trcrad, local operation before glob_sum_delay
31   PUBLIC   sum3x3        ! used in trcrad, do a sum over 3x3 boxes
32   PUBLIC   DDPDD         ! also used in closea module
33   PUBLIC   glob_min, glob_max
34#if defined key_nosignedzero
35   PUBLIC SIGN
36#endif
37
38   INTERFACE glob_sum
39      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d
40   END INTERFACE
41   INTERFACE glob_sum_full
42      MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d
43   END INTERFACE
44   INTERFACE local_sum
45      MODULE PROCEDURE local_sum_2d, local_sum_3d
46   END INTERFACE
47   INTERFACE sum3x3
48      MODULE PROCEDURE sum3x3_2d, sum3x3_3d
49   END INTERFACE
50   INTERFACE glob_min
51      MODULE PROCEDURE glob_min_2d, glob_min_3d
52   END INTERFACE
53   INTERFACE glob_max
54      MODULE PROCEDURE glob_max_2d, glob_max_3d
55   END INTERFACE
56
57#if defined key_nosignedzero
58   INTERFACE SIGN
59      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
60         &             SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,          &
61         &             SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B
62   END INTERFACE
63#endif
64
65   !! * 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(wp)              ::  local_sum_2d
146      !
147      !!-----------------------------------------------------------------------
148      !
149      COMPLEX(wp)::   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, wp ), 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(wp)              ::  local_sum_3d
175      !
176      !!-----------------------------------------------------------------------
177      !
178      COMPLEX(wp)::   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, wp ), 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      DO_2D_11_11
220         IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN   ! bottom left corber of a 3x3 box
221            ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
222            jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
223            IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
224               p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2))
225            ENDIF
226         ENDIF
227      END_2D
228      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. )
229      IF( nbondi /= -1 ) THEN
230         IF( MOD(mig(    1), 3) == 1 )   p2d(    1,:) = p2d(    2,:)
231         IF( MOD(mig(    1), 3) == 2 )   p2d(    2,:) = p2d(    1,:)
232      ENDIF
233      IF( nbondi /=  1 ) THEN
234         IF( MOD(mig(jpi-2), 3) == 1 )   p2d(  jpi,:) = p2d(jpi-1,:)
235         IF( MOD(mig(jpi-2), 3) == 0 )   p2d(jpi-1,:) = p2d(  jpi,:)
236      ENDIF
237      IF( nbondj /= -1 ) THEN
238         IF( MOD(mjg(    1), 3) == 1 )   p2d(:,    1) = p2d(:,    2)
239         IF( MOD(mjg(    1), 3) == 2 )   p2d(:,    2) = p2d(:,    1)
240      ENDIF
241      IF( nbondj /=  1 ) THEN
242         IF( MOD(mjg(jpj-2), 3) == 1 )   p2d(:,  jpj) = p2d(:,jpj-1)
243         IF( MOD(mjg(jpj-2), 3) == 0 )   p2d(:,jpj-1) = p2d(:,  jpj)
244      ENDIF
245      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. )
246
247   END SUBROUTINE sum3x3_2d
248
249   SUBROUTINE sum3x3_3d( p3d )
250      !!-----------------------------------------------------------------------
251      !!                  ***  routine sum3x3_3d  ***
252      !!
253      !! ** Purpose : sum over 3x3 boxes
254      !!----------------------------------------------------------------------
255      REAL(wp), DIMENSION (:,:,:), INTENT(inout) ::   p3d
256      !
257      INTEGER ::   ji, ji2, jj, jj2, jn     ! dummy loop indices
258      INTEGER ::   ipn                      ! Third dimension size
259      !!----------------------------------------------------------------------
260      !
261      IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) 
262      IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) 
263      ipn = SIZE(p3d,3)
264      !
265      DO jn = 1, ipn
266         DO_2D_11_11
267            IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN   ! bottom left corber of a 3x3 box
268               ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
269               jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
270               IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
271                  p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn))
272               ENDIF
273            ENDIF
274         END_2D
275      END DO
276      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )
277      IF( nbondi /= -1 ) THEN
278         IF( MOD(mig(    1), 3) == 1 )   p3d(    1,:,:) = p3d(    2,:,:)
279         IF( MOD(mig(    1), 3) == 2 )   p3d(    2,:,:) = p3d(    1,:,:)
280      ENDIF
281      IF( nbondi /=  1 ) THEN
282         IF( MOD(mig(jpi-2), 3) == 1 )   p3d(  jpi,:,:) = p3d(jpi-1,:,:)
283         IF( MOD(mig(jpi-2), 3) == 0 )   p3d(jpi-1,:,:) = p3d(  jpi,:,:)
284      ENDIF
285      IF( nbondj /= -1 ) THEN
286         IF( MOD(mjg(    1), 3) == 1 )   p3d(:,    1,:) = p3d(:,    2,:)
287         IF( MOD(mjg(    1), 3) == 2 )   p3d(:,    2,:) = p3d(:,    1,:)
288      ENDIF
289      IF( nbondj /=  1 ) THEN
290         IF( MOD(mjg(jpj-2), 3) == 1 )   p3d(:,  jpj,:) = p3d(:,jpj-1,:)
291         IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:)
292      ENDIF
293      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )
294
295   END SUBROUTINE sum3x3_3d
296
297
298   SUBROUTINE DDPDD( ydda, yddb )
299      !!----------------------------------------------------------------------
300      !!               ***  ROUTINE DDPDD ***
301      !!
302      !! ** Purpose : Add a scalar element to a sum
303      !!
304      !!
305      !! ** Method  : The code uses the compensated summation with doublet
306      !!              (sum,error) emulated useing complex numbers. ydda is the
307      !!               scalar to add to the summ yddb
308      !!
309      !! ** Action  : This does only work for MPI.
310      !!
311      !! References : Using Acurate Arithmetics to Improve Numerical
312      !!              Reproducibility and Sability in Parallel Applications
313      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
314      !!----------------------------------------------------------------------
315      COMPLEX(wp), INTENT(in   ) ::   ydda
316      COMPLEX(wp), INTENT(inout) ::   yddb
317      !
318      REAL(wp) :: zerr, zt1, zt2  ! local work variables
319      !!-----------------------------------------------------------------------
320      !
321      ! Compute ydda + yddb using Knuth's trick.
322      zt1  = REAL(ydda) + REAL(yddb)
323      zerr = zt1 - REAL(ydda)
324      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
325         &   + AIMAG(ydda)         + AIMAG(yddb)
326      !
327      ! The result is t1 + t2, after normalization.
328      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
329      !
330   END SUBROUTINE DDPDD
331
332#if defined key_nosignedzero
333   !!----------------------------------------------------------------------
334   !!   'key_nosignedzero'                                         F90 SIGN
335   !!----------------------------------------------------------------------
336
337   FUNCTION SIGN_SCALAR( pa, pb )
338      !!-----------------------------------------------------------------------
339      !!                  ***  FUNCTION SIGN_SCALAR  ***
340      !!
341      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
342      !!-----------------------------------------------------------------------
343      REAL(wp) :: pa,pb          ! input
344      REAL(wp) :: SIGN_SCALAR    ! result
345      !!-----------------------------------------------------------------------
346      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
347      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
348      ENDIF
349   END FUNCTION SIGN_SCALAR
350
351
352   FUNCTION SIGN_ARRAY_1D( pa, pb )
353      !!-----------------------------------------------------------------------
354      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
355      !!
356      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
357      !!-----------------------------------------------------------------------
358      REAL(wp) :: pa,pb(:)                   ! input
359      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
360      !!-----------------------------------------------------------------------
361      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
362      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
363      END WHERE
364   END FUNCTION SIGN_ARRAY_1D
365
366
367   FUNCTION SIGN_ARRAY_2D(pa,pb)
368      !!-----------------------------------------------------------------------
369      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
370      !!
371      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
372      !!-----------------------------------------------------------------------
373      REAL(wp) :: pa,pb(:,:)      ! input
374      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
375      !!-----------------------------------------------------------------------
376      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
377      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
378      END WHERE
379   END FUNCTION SIGN_ARRAY_2D
380
381   FUNCTION SIGN_ARRAY_3D(pa,pb)
382      !!-----------------------------------------------------------------------
383      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
384      !!
385      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
386      !!-----------------------------------------------------------------------
387      REAL(wp) :: pa,pb(:,:,:)      ! input
388      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
389      !!-----------------------------------------------------------------------
390      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
391      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
392      END WHERE
393   END FUNCTION SIGN_ARRAY_3D
394
395
396   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
397      !!-----------------------------------------------------------------------
398      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
399      !!
400      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
401      !!-----------------------------------------------------------------------
402      REAL(wp) :: pa(:),pb(:)      ! input
403      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
404      !!-----------------------------------------------------------------------
405      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
406      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
407      END WHERE
408   END FUNCTION SIGN_ARRAY_1D_A
409
410
411   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
412      !!-----------------------------------------------------------------------
413      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
414      !!
415      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
416      !!-----------------------------------------------------------------------
417      REAL(wp) :: pa(:,:),pb(:,:)      ! input
418      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
419      !!-----------------------------------------------------------------------
420      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
421      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
422      END WHERE
423   END FUNCTION SIGN_ARRAY_2D_A
424
425
426   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
427      !!-----------------------------------------------------------------------
428      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
429      !!
430      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
431      !!-----------------------------------------------------------------------
432      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
433      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
434      !!-----------------------------------------------------------------------
435      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
436      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
437      END WHERE
438   END FUNCTION SIGN_ARRAY_3D_A
439
440
441   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
442      !!-----------------------------------------------------------------------
443      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
444      !!
445      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
446      !!-----------------------------------------------------------------------
447      REAL(wp) :: pa(:),pb      ! input
448      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
449      !!-----------------------------------------------------------------------
450      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
451      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
452      ENDIF
453   END FUNCTION SIGN_ARRAY_1D_B
454
455
456   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
457      !!-----------------------------------------------------------------------
458      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
459      !!
460      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
461      !!-----------------------------------------------------------------------
462      REAL(wp) :: pa(:,:),pb      ! input
463      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
464      !!-----------------------------------------------------------------------
465      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
466      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
467      ENDIF
468   END FUNCTION SIGN_ARRAY_2D_B
469
470
471   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
472      !!-----------------------------------------------------------------------
473      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
474      !!
475      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
476      !!-----------------------------------------------------------------------
477      REAL(wp) :: pa(:,:,:),pb      ! input
478      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
479      !!-----------------------------------------------------------------------
480      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
481      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
482      ENDIF
483   END FUNCTION SIGN_ARRAY_3D_B
484#endif
485
486   !!======================================================================
487END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.