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 @ 11574

Last change on this file since 11574 was 10425, checked in by smasson, 5 years ago

trunk: merge back dev_r10164_HPC09_ESIWACE_PREP_MERGE@10424 into the trunk

  • Property svn:keywords set to Id
File size: 20.0 KB
RevLine 
[2003]1MODULE lib_fortran
2   !!======================================================================
3   !!                       ***  MODULE  lib_fortran  ***
4   !! Fortran utilities:  includes some low levels fortran functionality
5   !!======================================================================
[2307]6   !! History :  3.2  !  2010-05  (M. Dunphy, R. Benshila)  Original code
[4161]7   !!            3.4  !  2013-06  (C. Rousset)  add glob_min, glob_max
8   !!                                           + 3d dim. of input is fexible (jpk, jpl...)
[7646]9   !!            4.0  !  2016-06  (T. Lovato)  double precision global sum by default
[2003]10   !!----------------------------------------------------------------------
[2307]11
[2003]12   !!----------------------------------------------------------------------
[3764]13   !!   glob_sum    : generic interface for global masked summation over
[2307]14   !!                 the interior domain for 1 or 2 2D or 3D arrays
[3764]15   !!                 it works only for T points
[2307]16   !!   SIGN        : generic interface for SIGN to overwrite f95 behaviour
17   !!                 of intrinsinc sign function
18   !!----------------------------------------------------------------------
[3632]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
[10425]23   USE lbclnk          ! ocean lateral boundary conditions
[2003]24
25   IMPLICIT NONE
26   PRIVATE
27
[6140]28   PUBLIC   glob_sum      ! used in many places (masked with tmask_i)
[7646]29   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos)
[10425]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
[6140]32   PUBLIC   DDPDD         ! also used in closea module
[4161]33   PUBLIC   glob_min, glob_max
[2341]34#if defined key_nosignedzero
[2003]35   PUBLIC SIGN
36#endif
37
38   INTERFACE glob_sum
[10425]39      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d
[2003]40   END INTERFACE
[6140]41   INTERFACE glob_sum_full
42      MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d
43   END INTERFACE
[10425]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
[4161]50   INTERFACE glob_min
[10425]51      MODULE PROCEDURE glob_min_2d, glob_min_3d
[4161]52   END INTERFACE
53   INTERFACE glob_max
[10425]54      MODULE PROCEDURE glob_max_2d, glob_max_3d
[4161]55   END INTERFACE
[2003]56
[3764]57#if defined key_nosignedzero
[2003]58   INTERFACE SIGN
[2307]59      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
[3764]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
[2003]62   END INTERFACE
63#endif
64
[2307]65   !!----------------------------------------------------------------------
[9598]66   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
[3764]67   !! $Id$
[10068]68   !! Software governed by the CeCILL license (see ./LICENSE)
[2307]69   !!----------------------------------------------------------------------
[3764]70CONTAINS
[2003]71
[10425]72#  define GLOBSUM_CODE
[3764]73
[10425]74#     define DIM_1d
75#     define FUNCTION_GLOBSUM           glob_sum_1d
76#     include "lib_fortran_generic.h90"
77#     undef FUNCTION_GLOBSUM
78#     undef DIM_1d
[2307]79
[10425]80#     define DIM_2d
81#     define OPERATION_GLOBSUM
82#     define FUNCTION_GLOBSUM           glob_sum_2d
83#     include "lib_fortran_generic.h90"
84#     undef FUNCTION_GLOBSUM
85#     undef OPERATION_GLOBSUM
86#     define OPERATION_FULL_GLOBSUM
87#     define FUNCTION_GLOBSUM           glob_sum_full_2d
88#     include "lib_fortran_generic.h90"
89#     undef FUNCTION_GLOBSUM
90#     undef OPERATION_FULL_GLOBSUM
91#     undef DIM_2d
[2307]92
[10425]93#     define DIM_3d
94#     define OPERATION_GLOBSUM
95#     define FUNCTION_GLOBSUM           glob_sum_3d
96#     include "lib_fortran_generic.h90"
97#     undef FUNCTION_GLOBSUM
98#     undef OPERATION_GLOBSUM
99#     define OPERATION_FULL_GLOBSUM
100#     define FUNCTION_GLOBSUM           glob_sum_full_3d
101#     include "lib_fortran_generic.h90"
102#     undef FUNCTION_GLOBSUM
103#     undef OPERATION_FULL_GLOBSUM
104#     undef DIM_3d
[2307]105
[10425]106#  undef GLOBSUM_CODE
[2307]107
[10425]108
109#  define GLOBMINMAX_CODE
110
111#     define DIM_2d
112#     define OPERATION_GLOBMIN
113#     define FUNCTION_GLOBMINMAX           glob_min_2d
114#     include "lib_fortran_generic.h90"
115#     undef FUNCTION_GLOBMINMAX
116#     undef OPERATION_GLOBMIN
117#     define OPERATION_GLOBMAX
118#     define FUNCTION_GLOBMINMAX           glob_max_2d
119#     include "lib_fortran_generic.h90"
120#     undef FUNCTION_GLOBMINMAX
121#     undef OPERATION_GLOBMAX
122#     undef DIM_2d
123
124#     define DIM_3d
125#     define OPERATION_GLOBMIN
126#     define FUNCTION_GLOBMINMAX           glob_min_3d
127#     include "lib_fortran_generic.h90"
128#     undef FUNCTION_GLOBMINMAX
129#     undef OPERATION_GLOBMIN
130#     define OPERATION_GLOBMAX
131#     define FUNCTION_GLOBMINMAX           glob_max_3d
132#     include "lib_fortran_generic.h90"
133#     undef FUNCTION_GLOBMINMAX
134#     undef OPERATION_GLOBMAX
135#     undef DIM_3d
136#  undef GLOBMINMAX_CODE
137
138!                          ! FUNCTION local_sum !
139
140   FUNCTION local_sum_2d( ptab )
[2307]141      !!----------------------------------------------------------------------
[10425]142      REAL(wp),  INTENT(in   ) ::   ptab(:,:) ! array on which operation is applied
143      COMPLEX(wp)              ::  local_sum_2d
144      !
[2003]145      !!-----------------------------------------------------------------------
[2307]146      !
147      COMPLEX(wp)::   ctmp
148      REAL(wp)   ::   ztmp
[10425]149      INTEGER    ::   ji, jj    ! dummy loop indices
150      INTEGER    ::   ipi, ipj  ! dimensions
[2307]151      !!-----------------------------------------------------------------------
152      !
[10425]153      ipi = SIZE(ptab,1)   ! 1st dimension
154      ipj = SIZE(ptab,2)   ! 2nd dimension
[4161]155      !
[10425]156      ctmp = CMPLX( 0.e0, 0.e0, wp )   ! warning ctmp is cumulated
157
158      DO jj = 1, ipj
159         DO ji = 1, ipi
160            ztmp =  ptab(ji,jj) * tmask_i(ji,jj)
161            CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
162         END DO
[2307]163      END DO
164      !
[10425]165      local_sum_2d = ctmp
166       
167   END FUNCTION local_sum_2d
[2307]168
[10425]169   FUNCTION local_sum_3d( ptab )
[6140]170      !!----------------------------------------------------------------------
[10425]171      REAL(wp),  INTENT(in   ) ::   ptab(:,:,:) ! array on which operation is applied
172      COMPLEX(wp)              ::  local_sum_3d
173      !
[6140]174      !!-----------------------------------------------------------------------
175      !
176      COMPLEX(wp)::   ctmp
177      REAL(wp)   ::   ztmp
178      INTEGER    ::   ji, jj, jk   ! dummy loop indices
[10425]179      INTEGER    ::   ipi, ipj, ipk    ! dimensions
[6140]180      !!-----------------------------------------------------------------------
181      !
[10425]182      ipi = SIZE(ptab,1)   ! 1st dimension
183      ipj = SIZE(ptab,2)   ! 2nd dimension
184      ipk = SIZE(ptab,3)   ! 3rd dimension
[6140]185      !
[10425]186      ctmp = CMPLX( 0.e0, 0.e0, wp )   ! warning ctmp is cumulated
[6140]187
[10425]188      DO jk = 1, ipk
189        DO jj = 1, ipj
190          DO ji = 1, ipi
191             ztmp =  ptab(ji,jj,jk) * tmask_i(ji,jj)
192             CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
193          END DO
194        END DO
[4161]195      END DO
196      !
[10425]197      local_sum_3d = ctmp
198       
199   END FUNCTION local_sum_3d
[4161]200
[10425]201!                          ! FUNCTION sum3x3 !
[4161]202
[10425]203   SUBROUTINE sum3x3_2d( p2d )
[4161]204      !!-----------------------------------------------------------------------
[10425]205      !!                  ***  routine sum3x3_2d  ***
[4161]206      !!
[10425]207      !! ** Purpose : sum over 3x3 boxes
208      !!----------------------------------------------------------------------
209      REAL(wp), DIMENSION (:,:), INTENT(inout) ::   p2d
[4161]210      !
[10425]211      INTEGER ::   ji, ji2, jj, jj2     ! dummy loop indices
212      !!----------------------------------------------------------------------
[4161]213      !
[10425]214      IF( SIZE(p2d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the first dimension is not equal to jpi' ) 
215      IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) 
[4161]216      !
[10425]217      DO jj = 1, jpj
218         DO ji = 1, jpi 
219            IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN   ! bottom left corber of a 3x3 box
220               ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
221               jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
222               IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
223                  p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2))
224               ENDIF
225            ENDIF
226         END DO
[4161]227      END DO
[10425]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. )
[4161]246
[10425]247   END SUBROUTINE sum3x3_2d
248
249   SUBROUTINE sum3x3_3d( p3d )
[4161]250      !!-----------------------------------------------------------------------
[10425]251      !!                  ***  routine sum3x3_3d  ***
[4161]252      !!
[10425]253      !! ** Purpose : sum over 3x3 boxes
254      !!----------------------------------------------------------------------
255      REAL(wp), DIMENSION (:,:,:), INTENT(inout) ::   p3d
[4161]256      !
[10425]257      INTEGER ::   ji, ji2, jj, jj2, jn     ! dummy loop indices
258      INTEGER ::   ipn                      ! Third dimension size
259      !!----------------------------------------------------------------------
[4161]260      !
[10425]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)
[4161]264      !
[10425]265      DO jn = 1, ipn
266         DO jj = 1, jpj
267            DO ji = 1, jpi 
268               IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN   ! bottom left corber of a 3x3 box
269                  ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box
270                  jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box
271                  IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN                    ! the box is fully included in the local mpi domain
272                     p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn))
273                  ENDIF
274               ENDIF
275            END DO
276         END DO
[4161]277      END DO
[10425]278      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )
279      IF( nbondi /= -1 ) THEN
280         IF( MOD(mig(    1), 3) == 1 )   p3d(    1,:,:) = p3d(    2,:,:)
281         IF( MOD(mig(    1), 3) == 2 )   p3d(    2,:,:) = p3d(    1,:,:)
282      ENDIF
283      IF( nbondi /=  1 ) THEN
284         IF( MOD(mig(jpi-2), 3) == 1 )   p3d(  jpi,:,:) = p3d(jpi-1,:,:)
285         IF( MOD(mig(jpi-2), 3) == 0 )   p3d(jpi-1,:,:) = p3d(  jpi,:,:)
286      ENDIF
287      IF( nbondj /= -1 ) THEN
288         IF( MOD(mjg(    1), 3) == 1 )   p3d(:,    1,:) = p3d(:,    2,:)
289         IF( MOD(mjg(    1), 3) == 2 )   p3d(:,    2,:) = p3d(:,    1,:)
290      ENDIF
291      IF( nbondj /=  1 ) THEN
292         IF( MOD(mjg(jpj-2), 3) == 1 )   p3d(:,  jpj,:) = p3d(:,jpj-1,:)
293         IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:)
294      ENDIF
295      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )
[4161]296
[10425]297   END SUBROUTINE sum3x3_3d
[4161]298
299
[2003]300   SUBROUTINE DDPDD( ydda, yddb )
301      !!----------------------------------------------------------------------
302      !!               ***  ROUTINE DDPDD ***
[3764]303      !!
[2003]304      !! ** Purpose : Add a scalar element to a sum
305      !!
[3764]306      !!
307      !! ** Method  : The code uses the compensated summation with doublet
[2003]308      !!              (sum,error) emulated useing complex numbers. ydda is the
[3764]309      !!               scalar to add to the summ yddb
[2003]310      !!
[3764]311      !! ** Action  : This does only work for MPI.
312      !!
[2003]313      !! References : Using Acurate Arithmetics to Improve Numerical
314      !!              Reproducibility and Sability in Parallel Applications
[3764]315      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
[2003]316      !!----------------------------------------------------------------------
[2307]317      COMPLEX(wp), INTENT(in   ) ::   ydda
318      COMPLEX(wp), INTENT(inout) ::   yddb
319      !
[2003]320      REAL(wp) :: zerr, zt1, zt2  ! local work variables
[2307]321      !!-----------------------------------------------------------------------
322      !
[2003]323      ! Compute ydda + yddb using Knuth's trick.
[2307]324      zt1  = REAL(ydda) + REAL(yddb)
325      zerr = zt1 - REAL(ydda)
326      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
327         &   + AIMAG(ydda)         + AIMAG(yddb)
328      !
[2003]329      ! The result is t1 + t2, after normalization.
[2307]330      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
331      !
[2003]332   END SUBROUTINE DDPDD
333
334#if defined key_nosignedzero
[2307]335   !!----------------------------------------------------------------------
336   !!   'key_nosignedzero'                                         F90 SIGN
337   !!----------------------------------------------------------------------
[3764]338
[2307]339   FUNCTION SIGN_SCALAR( pa, pb )
[2003]340      !!-----------------------------------------------------------------------
341      !!                  ***  FUNCTION SIGN_SCALAR  ***
342      !!
343      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
344      !!-----------------------------------------------------------------------
345      REAL(wp) :: pa,pb          ! input
[2307]346      REAL(wp) :: SIGN_SCALAR    ! result
347      !!-----------------------------------------------------------------------
348      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
349      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
[2003]350      ENDIF
351   END FUNCTION SIGN_SCALAR
352
[2307]353
[3764]354   FUNCTION SIGN_ARRAY_1D( pa, pb )
[2003]355      !!-----------------------------------------------------------------------
356      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
357      !!
358      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
359      !!-----------------------------------------------------------------------
[2307]360      REAL(wp) :: pa,pb(:)                   ! input
[2003]361      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
[2307]362      !!-----------------------------------------------------------------------
363      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
364      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
[2003]365      END WHERE
366   END FUNCTION SIGN_ARRAY_1D
367
[2307]368
[3764]369   FUNCTION SIGN_ARRAY_2D(pa,pb)
[2003]370      !!-----------------------------------------------------------------------
371      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
372      !!
373      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
374      !!-----------------------------------------------------------------------
375      REAL(wp) :: pa,pb(:,:)      ! input
376      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
[2307]377      !!-----------------------------------------------------------------------
378      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
379      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
[2003]380      END WHERE
381   END FUNCTION SIGN_ARRAY_2D
382
[3764]383   FUNCTION SIGN_ARRAY_3D(pa,pb)
[2003]384      !!-----------------------------------------------------------------------
385      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
386      !!
387      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
388      !!-----------------------------------------------------------------------
389      REAL(wp) :: pa,pb(:,:,:)      ! input
390      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
[2307]391      !!-----------------------------------------------------------------------
392      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
393      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
[2003]394      END WHERE
395   END FUNCTION SIGN_ARRAY_3D
396
[2307]397
[3764]398   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
[2003]399      !!-----------------------------------------------------------------------
400      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
401      !!
402      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
403      !!-----------------------------------------------------------------------
404      REAL(wp) :: pa(:),pb(:)      ! input
[2307]405      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
406      !!-----------------------------------------------------------------------
407      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
408      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
[2003]409      END WHERE
410   END FUNCTION SIGN_ARRAY_1D_A
411
[2307]412
[3764]413   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
[2003]414      !!-----------------------------------------------------------------------
415      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
416      !!
417      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
418      !!-----------------------------------------------------------------------
419      REAL(wp) :: pa(:,:),pb(:,:)      ! input
420      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
[2307]421      !!-----------------------------------------------------------------------
422      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
423      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
[2003]424      END WHERE
425   END FUNCTION SIGN_ARRAY_2D_A
426
[2307]427
[3764]428   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
[2003]429      !!-----------------------------------------------------------------------
430      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
431      !!
432      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
433      !!-----------------------------------------------------------------------
434      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
435      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
[2307]436      !!-----------------------------------------------------------------------
437      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
438      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
[2003]439      END WHERE
440   END FUNCTION SIGN_ARRAY_3D_A
441
[2307]442
[3764]443   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
[2003]444      !!-----------------------------------------------------------------------
445      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
446      !!
447      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
448      !!-----------------------------------------------------------------------
449      REAL(wp) :: pa(:),pb      ! input
450      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
[2307]451      !!-----------------------------------------------------------------------
452      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
453      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
[2003]454      ENDIF
455   END FUNCTION SIGN_ARRAY_1D_B
456
[2307]457
[3764]458   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
[2003]459      !!-----------------------------------------------------------------------
460      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
461      !!
462      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
463      !!-----------------------------------------------------------------------
464      REAL(wp) :: pa(:,:),pb      ! input
465      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
[2307]466      !!-----------------------------------------------------------------------
467      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
468      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
[2003]469      ENDIF
470   END FUNCTION SIGN_ARRAY_2D_B
471
[2307]472
[3764]473   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
[2003]474      !!-----------------------------------------------------------------------
475      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
476      !!
477      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
478      !!-----------------------------------------------------------------------
479      REAL(wp) :: pa(:,:,:),pb      ! input
480      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
[2307]481      !!-----------------------------------------------------------------------
482      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
483      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
[2003]484      ENDIF
485   END FUNCTION SIGN_ARRAY_3D_B
486#endif
487
[2307]488   !!======================================================================
[2003]489END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.