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 branches/UKMO/dev_r8183_GC_couple_pkg/NEMOGCM/TOOLS/DOMAINcfg/src – NEMO

source: branches/UKMO/dev_r8183_GC_couple_pkg/NEMOGCM/TOOLS/DOMAINcfg/src/lib_fortran.f90 @ 8730

Last change on this file since 8730 was 8730, checked in by dancopsey, 6 years ago

Cleared out SVN keywords.

File size: 24.3 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   !!----------------------------------------------------------------------
10
11   !!----------------------------------------------------------------------
12   !!   glob_sum    : generic interface for global masked summation over
13   !!                 the interior domain for 1 or 2 2D or 3D arrays
14   !!                 it works only for T points
15   !!   SIGN        : generic interface for SIGN to overwrite f95 behaviour
16   !!                 of intrinsinc sign function
17   !!----------------------------------------------------------------------
18   USE par_oce         ! Ocean parameter
19   USE dom_oce         ! ocean domain
20   USE in_out_manager  ! I/O manager
21   USE lib_mpp         ! distributed memory computing
22
23   IMPLICIT NONE
24   PRIVATE
25
26   PUBLIC   glob_sum      ! used in many places (masked with tmask_i)
27   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie omly over the halos)
28   PUBLIC   DDPDD         ! also used in closea module
29   PUBLIC   glob_min, glob_max
30
31   PUBLIC SIGN
32
33
34   INTERFACE glob_sum
35      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, &
36         &             glob_sum_2d_a, glob_sum_3d_a
37   END INTERFACE
38   INTERFACE glob_sum_full
39      MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d
40   END INTERFACE
41   INTERFACE glob_min
42      MODULE PROCEDURE glob_min_2d, glob_min_3d,glob_min_2d_a, glob_min_3d_a 
43   END INTERFACE
44   INTERFACE glob_max
45      MODULE PROCEDURE glob_max_2d, glob_max_3d,glob_max_2d_a, glob_max_3d_a 
46   END INTERFACE
47
48
49   INTERFACE SIGN
50      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
51         &             SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,          &
52         &             SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B
53   END INTERFACE
54
55
56   !!----------------------------------------------------------------------
57   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
58   !! $Id$
59   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
60   !!----------------------------------------------------------------------
61CONTAINS
62
63
64   ! --- SUM ---
65
66   FUNCTION glob_sum_1d( ptab, kdim )
67      !!-----------------------------------------------------------------------
68      !!                  ***  FUNCTION  glob_sum_1D  ***
69      !!
70      !! ** Purpose : perform a masked sum on the inner global domain of a 1D array
71      !!-----------------------------------------------------------------------
72      INTEGER :: kdim
73      REAL(wp), INTENT(in), DIMENSION(kdim) ::   ptab        ! input 1D array
74      REAL(wp)                              ::   glob_sum_1d ! global sum
75      !!-----------------------------------------------------------------------
76      !
77      glob_sum_1d = SUM( ptab(:) )
78      IF( lk_mpp )   CALL mpp_sum( glob_sum_1d )
79      !
80   END FUNCTION glob_sum_1d
81
82   FUNCTION glob_sum_2d( ptab )
83      !!-----------------------------------------------------------------------
84      !!                  ***  FUNCTION  glob_sum_2D  ***
85      !!
86      !! ** Purpose : perform a masked sum on the inner global domain of a 2D array
87      !!-----------------------------------------------------------------------
88      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array
89      REAL(wp)                             ::   glob_sum_2d   ! global masked sum
90      !!-----------------------------------------------------------------------
91      !
92      glob_sum_2d = SUM( ptab(:,:)*tmask_i(:,:) )
93      IF( lk_mpp )   CALL mpp_sum( glob_sum_2d )
94      !
95   END FUNCTION glob_sum_2d
96
97
98   FUNCTION glob_sum_3d( ptab )
99      !!-----------------------------------------------------------------------
100      !!                  ***  FUNCTION  glob_sum_3D  ***
101      !!
102      !! ** Purpose : perform a masked sum on the inner global domain of a 3D array
103      !!-----------------------------------------------------------------------
104      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array
105      REAL(wp)                               ::   glob_sum_3d   ! global masked sum
106      !!
107      INTEGER :: jk
108      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
109      !!-----------------------------------------------------------------------
110      !
111      ijpk = SIZE(ptab,3)
112      !
113      glob_sum_3d = 0.e0
114      DO jk = 1, ijpk
115         glob_sum_3d = glob_sum_3d + SUM( ptab(:,:,jk)*tmask_i(:,:) )
116      END DO
117      IF( lk_mpp )   CALL mpp_sum( glob_sum_3d )
118      !
119   END FUNCTION glob_sum_3d
120
121
122   FUNCTION glob_sum_2d_a( ptab1, ptab2 )
123      !!-----------------------------------------------------------------------
124      !!                  ***  FUNCTION  glob_sum_2D _a ***
125      !!
126      !! ** Purpose : perform a masked sum on the inner global domain of two 2D array
127      !!-----------------------------------------------------------------------
128      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array
129      REAL(wp)            , DIMENSION(2)   ::   glob_sum_2d_a   ! global masked sum
130      !!-----------------------------------------------------------------------
131      !
132      glob_sum_2d_a(1) = SUM( ptab1(:,:)*tmask_i(:,:) )
133      glob_sum_2d_a(2) = SUM( ptab2(:,:)*tmask_i(:,:) )
134      IF( lk_mpp )   CALL mpp_sum( glob_sum_2d_a, 2 )
135      !
136   END FUNCTION glob_sum_2d_a
137
138
139   FUNCTION glob_sum_3d_a( ptab1, ptab2 )
140      !!-----------------------------------------------------------------------
141      !!                  ***  FUNCTION  glob_sum_3D_a ***
142      !!
143      !! ** Purpose : perform a masked sum on the inner global domain of two 3D array
144      !!-----------------------------------------------------------------------
145      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array
146      REAL(wp)            , DIMENSION(2)     ::   glob_sum_3d_a   ! global masked sum
147      !!
148      INTEGER :: jk
149      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
150      !!-----------------------------------------------------------------------
151      !
152      ijpk = SIZE(ptab1,3)
153      !
154      glob_sum_3d_a(:) = 0.e0
155      DO jk = 1, ijpk
156         glob_sum_3d_a(1) = glob_sum_3d_a(1) + SUM( ptab1(:,:,jk)*tmask_i(:,:) )
157         glob_sum_3d_a(2) = glob_sum_3d_a(2) + SUM( ptab2(:,:,jk)*tmask_i(:,:) )
158      END DO
159      IF( lk_mpp )   CALL mpp_sum( glob_sum_3d_a, 2 )
160      !
161   END FUNCTION glob_sum_3d_a
162
163   FUNCTION glob_sum_full_2d( ptab )
164      !!----------------------------------------------------------------------
165      !!                  ***  FUNCTION  glob_sum_full_2d ***
166      !!
167      !! ** Purpose : perform a sum in calling DDPDD routine (nomask)
168      !!----------------------------------------------------------------------
169      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab
170      REAL(wp)                             ::   glob_sum_full_2d   ! global sum
171      !!
172      !!-----------------------------------------------------------------------
173      !
174      glob_sum_full_2d = SUM( ptab(:,:) * tmask_h(:,:) )
175      IF( lk_mpp )   CALL mpp_sum( glob_sum_full_2d )
176      !
177   END FUNCTION glob_sum_full_2d
178
179   FUNCTION glob_sum_full_3d( ptab )
180      !!----------------------------------------------------------------------
181      !!                  ***  FUNCTION  glob_sum_full_3d ***
182      !!
183      !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine (nomask)
184      !!----------------------------------------------------------------------
185      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab
186      REAL(wp)                               ::   glob_sum_full_3d   ! global sum
187      !!
188      INTEGER    ::   ji, jj, jk   ! dummy loop indices
189      INTEGER    ::   ijpk ! local variables: size of ptab
190      !!-----------------------------------------------------------------------
191      !
192      ijpk = SIZE(ptab,3)
193      !
194      glob_sum_full_3d = 0.e0
195      DO jk = 1, ijpk
196         glob_sum_full_3d = glob_sum_full_3d + SUM( ptab(:,:,jk) * tmask_h(:,:) )
197      END DO
198      IF( lk_mpp )   CALL mpp_sum( glob_sum_full_3d )
199      !
200   END FUNCTION glob_sum_full_3d
201
202
203
204   ! --- MIN ---
205   FUNCTION glob_min_2d( ptab ) 
206      !!-----------------------------------------------------------------------
207      !!                  ***  FUNCTION  glob_min_2D  ***
208      !!
209      !! ** Purpose : perform a masked min on the inner global domain of a 2D array
210      !!-----------------------------------------------------------------------
211      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array
212      REAL(wp)                             ::   glob_min_2d   ! global masked min
213      !!-----------------------------------------------------------------------
214      !
215      glob_min_2d = MINVAL( ptab(:,:)*tmask_i(:,:) )
216      IF( lk_mpp )   CALL mpp_min( glob_min_2d )
217      !
218   END FUNCTION glob_min_2d
219 
220   FUNCTION glob_min_3d( ptab ) 
221      !!-----------------------------------------------------------------------
222      !!                  ***  FUNCTION  glob_min_3D  ***
223      !!
224      !! ** Purpose : perform a masked min on the inner global domain of a 3D array
225      !!-----------------------------------------------------------------------
226      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array
227      REAL(wp)                               ::   glob_min_3d   ! global masked min
228      !!
229      INTEGER :: jk
230      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
231      !!-----------------------------------------------------------------------
232      !
233      ijpk = SIZE(ptab,3)
234      !
235      glob_min_3d = MINVAL( ptab(:,:,1)*tmask_i(:,:) )
236      DO jk = 2, ijpk
237         glob_min_3d = MIN( glob_min_3d, MINVAL( ptab(:,:,jk)*tmask_i(:,:) ) )
238      END DO
239      IF( lk_mpp )   CALL mpp_min( glob_min_3d )
240      !
241   END FUNCTION glob_min_3d
242
243
244   FUNCTION glob_min_2d_a( ptab1, ptab2 ) 
245      !!-----------------------------------------------------------------------
246      !!                  ***  FUNCTION  glob_min_2D _a ***
247      !!
248      !! ** Purpose : perform a masked min on the inner global domain of two 2D array
249      !!-----------------------------------------------------------------------
250      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array
251      REAL(wp)            , DIMENSION(2)   ::   glob_min_2d_a   ! global masked min
252      !!-----------------------------------------------------------------------
253      !             
254      glob_min_2d_a(1) = MINVAL( ptab1(:,:)*tmask_i(:,:) )
255      glob_min_2d_a(2) = MINVAL( ptab2(:,:)*tmask_i(:,:) )
256      IF( lk_mpp )   CALL mpp_min( glob_min_2d_a, 2 )
257      !
258   END FUNCTION glob_min_2d_a
259 
260 
261   FUNCTION glob_min_3d_a( ptab1, ptab2 ) 
262      !!-----------------------------------------------------------------------
263      !!                  ***  FUNCTION  glob_min_3D_a ***
264      !!
265      !! ** Purpose : perform a masked min on the inner global domain of two 3D array
266      !!-----------------------------------------------------------------------
267      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array
268      REAL(wp)            , DIMENSION(2)     ::   glob_min_3d_a   ! global masked min
269      !!
270      INTEGER :: jk
271      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
272      !!-----------------------------------------------------------------------
273      !
274      ijpk = SIZE(ptab1,3)
275      !
276      glob_min_3d_a(1) = MINVAL( ptab1(:,:,1)*tmask_i(:,:) )
277      glob_min_3d_a(2) = MINVAL( ptab2(:,:,1)*tmask_i(:,:) )
278      DO jk = 2, ijpk
279         glob_min_3d_a(1) = MIN( glob_min_3d_a(1), MINVAL( ptab1(:,:,jk)*tmask_i(:,:) ) )
280         glob_min_3d_a(2) = MIN( glob_min_3d_a(2), MINVAL( ptab2(:,:,jk)*tmask_i(:,:) ) )
281      END DO
282      IF( lk_mpp )   CALL mpp_min( glob_min_3d_a, 2 )
283      !
284   END FUNCTION glob_min_3d_a
285
286   ! --- MAX ---
287   FUNCTION glob_max_2d( ptab ) 
288      !!-----------------------------------------------------------------------
289      !!                  ***  FUNCTION  glob_max_2D  ***
290      !!
291      !! ** Purpose : perform a masked max on the inner global domain of a 2D array
292      !!-----------------------------------------------------------------------
293      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array
294      REAL(wp)                             ::   glob_max_2d   ! global masked max
295      !!-----------------------------------------------------------------------
296      !
297      glob_max_2d = MAXVAL( ptab(:,:)*tmask_i(:,:) )
298      IF( lk_mpp )   CALL mpp_max( glob_max_2d )
299      !
300   END FUNCTION glob_max_2d
301 
302   FUNCTION glob_max_3d( ptab ) 
303      !!-----------------------------------------------------------------------
304      !!                  ***  FUNCTION  glob_max_3D  ***
305      !!
306      !! ** Purpose : perform a masked max on the inner global domain of a 3D array
307      !!-----------------------------------------------------------------------
308      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array
309      REAL(wp)                               ::   glob_max_3d   ! global masked max
310      !!
311      INTEGER :: jk
312      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
313      !!-----------------------------------------------------------------------
314      !
315      ijpk = SIZE(ptab,3)
316      !
317      glob_max_3d = MAXVAL( ptab(:,:,1)*tmask_i(:,:) )
318      DO jk = 2, ijpk
319         glob_max_3d = MAX( glob_max_3d, MAXVAL( ptab(:,:,jk)*tmask_i(:,:) ) )
320      END DO
321      IF( lk_mpp )   CALL mpp_max( glob_max_3d )
322      !
323   END FUNCTION glob_max_3d
324
325
326   FUNCTION glob_max_2d_a( ptab1, ptab2 ) 
327      !!-----------------------------------------------------------------------
328      !!                  ***  FUNCTION  glob_max_2D _a ***
329      !!
330      !! ** Purpose : perform a masked max on the inner global domain of two 2D array
331      !!-----------------------------------------------------------------------
332      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array
333      REAL(wp)            , DIMENSION(2)   ::   glob_max_2d_a   ! global masked max
334      !!-----------------------------------------------------------------------
335      !             
336      glob_max_2d_a(1) = MAXVAL( ptab1(:,:)*tmask_i(:,:) )
337      glob_max_2d_a(2) = MAXVAL( ptab2(:,:)*tmask_i(:,:) )
338      IF( lk_mpp )   CALL mpp_max( glob_max_2d_a, 2 )
339      !
340   END FUNCTION glob_max_2d_a
341 
342 
343   FUNCTION glob_max_3d_a( ptab1, ptab2 ) 
344      !!-----------------------------------------------------------------------
345      !!                  ***  FUNCTION  glob_max_3D_a ***
346      !!
347      !! ** Purpose : perform a masked max on the inner global domain of two 3D array
348      !!-----------------------------------------------------------------------
349      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array
350      REAL(wp)            , DIMENSION(2)     ::   glob_max_3d_a   ! global masked max
351      !!
352      INTEGER :: jk
353      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
354      !!-----------------------------------------------------------------------
355      !
356      ijpk = SIZE(ptab1,3)
357      !
358      glob_max_3d_a(1) = MAXVAL( ptab1(:,:,1)*tmask_i(:,:) )
359      glob_max_3d_a(2) = MAXVAL( ptab2(:,:,1)*tmask_i(:,:) )
360      DO jk = 2, ijpk
361         glob_max_3d_a(1) = MAX( glob_max_3d_a(1), MAXVAL( ptab1(:,:,jk)*tmask_i(:,:) ) )
362         glob_max_3d_a(2) = MAX( glob_max_3d_a(2), MAXVAL( ptab2(:,:,jk)*tmask_i(:,:) ) )
363      END DO
364      IF( lk_mpp )   CALL mpp_max( glob_max_3d_a, 2 )
365      !
366   END FUNCTION glob_max_3d_a
367
368
369   SUBROUTINE DDPDD( ydda, yddb )
370      !!----------------------------------------------------------------------
371      !!               ***  ROUTINE DDPDD ***
372      !!
373      !! ** Purpose : Add a scalar element to a sum
374      !!
375      !!
376      !! ** Method  : The code uses the compensated summation with doublet
377      !!              (sum,error) emulated useing complex numbers. ydda is the
378      !!               scalar to add to the summ yddb
379      !!
380      !! ** Action  : This does only work for MPI.
381      !!
382      !! References : Using Acurate Arithmetics to Improve Numerical
383      !!              Reproducibility and Sability in Parallel Applications
384      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
385      !!----------------------------------------------------------------------
386      COMPLEX(wp), INTENT(in   ) ::   ydda
387      COMPLEX(wp), INTENT(inout) ::   yddb
388      !
389      REAL(wp) :: zerr, zt1, zt2  ! local work variables
390      !!-----------------------------------------------------------------------
391      !
392      ! Compute ydda + yddb using Knuth's trick.
393      zt1  = REAL(ydda) + REAL(yddb)
394      zerr = zt1 - REAL(ydda)
395      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
396         &   + AIMAG(ydda)         + AIMAG(yddb)
397      !
398      ! The result is t1 + t2, after normalization.
399      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
400      !
401   END SUBROUTINE DDPDD
402
403   !!----------------------------------------------------------------------
404   !!   'key_nosignedzero'                                         F90 SIGN
405   !!----------------------------------------------------------------------
406
407   FUNCTION SIGN_SCALAR( pa, pb )
408      !!-----------------------------------------------------------------------
409      !!                  ***  FUNCTION SIGN_SCALAR  ***
410      !!
411      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
412      !!-----------------------------------------------------------------------
413      REAL(wp) :: pa,pb          ! input
414      REAL(wp) :: SIGN_SCALAR    ! result
415      !!-----------------------------------------------------------------------
416      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
417      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
418      ENDIF
419   END FUNCTION SIGN_SCALAR
420
421
422   FUNCTION SIGN_ARRAY_1D( pa, pb )
423      !!-----------------------------------------------------------------------
424      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
425      !!
426      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
427      !!-----------------------------------------------------------------------
428      REAL(wp) :: pa,pb(:)                   ! input
429      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
430      !!-----------------------------------------------------------------------
431      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
432      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
433      END WHERE
434   END FUNCTION SIGN_ARRAY_1D
435
436
437   FUNCTION SIGN_ARRAY_2D(pa,pb)
438      !!-----------------------------------------------------------------------
439      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
440      !!
441      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
442      !!-----------------------------------------------------------------------
443      REAL(wp) :: pa,pb(:,:)      ! input
444      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
445      !!-----------------------------------------------------------------------
446      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
447      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
448      END WHERE
449   END FUNCTION SIGN_ARRAY_2D
450
451   FUNCTION SIGN_ARRAY_3D(pa,pb)
452      !!-----------------------------------------------------------------------
453      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
454      !!
455      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
456      !!-----------------------------------------------------------------------
457      REAL(wp) :: pa,pb(:,:,:)      ! input
458      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
459      !!-----------------------------------------------------------------------
460      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
461      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
462      END WHERE
463   END FUNCTION SIGN_ARRAY_3D
464
465
466   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
467      !!-----------------------------------------------------------------------
468      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
469      !!
470      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
471      !!-----------------------------------------------------------------------
472      REAL(wp) :: pa(:),pb(:)      ! input
473      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
474      !!-----------------------------------------------------------------------
475      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
476      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
477      END WHERE
478   END FUNCTION SIGN_ARRAY_1D_A
479
480
481   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
482      !!-----------------------------------------------------------------------
483      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
484      !!
485      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
486      !!-----------------------------------------------------------------------
487      REAL(wp) :: pa(:,:),pb(:,:)      ! input
488      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
489      !!-----------------------------------------------------------------------
490      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
491      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
492      END WHERE
493   END FUNCTION SIGN_ARRAY_2D_A
494
495
496   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
497      !!-----------------------------------------------------------------------
498      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
499      !!
500      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
501      !!-----------------------------------------------------------------------
502      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
503      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
504      !!-----------------------------------------------------------------------
505      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
506      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
507      END WHERE
508   END FUNCTION SIGN_ARRAY_3D_A
509
510
511   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
512      !!-----------------------------------------------------------------------
513      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
514      !!
515      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
516      !!-----------------------------------------------------------------------
517      REAL(wp) :: pa(:),pb      ! input
518      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
519      !!-----------------------------------------------------------------------
520      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
521      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
522      ENDIF
523   END FUNCTION SIGN_ARRAY_1D_B
524
525
526   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
527      !!-----------------------------------------------------------------------
528      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
529      !!
530      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
531      !!-----------------------------------------------------------------------
532      REAL(wp) :: pa(:,:),pb      ! input
533      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
534      !!-----------------------------------------------------------------------
535      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
536      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
537      ENDIF
538   END FUNCTION SIGN_ARRAY_2D_B
539
540
541   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
542      !!-----------------------------------------------------------------------
543      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
544      !!
545      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
546      !!-----------------------------------------------------------------------
547      REAL(wp) :: pa(:,:,:),pb      ! input
548      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
549      !!-----------------------------------------------------------------------
550      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
551      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
552      ENDIF
553   END FUNCTION SIGN_ARRAY_3D_B
554
555   !!======================================================================
556END MODULE lib_fortran
Note: See TracBrowser for help on using the repository browser.