- Timestamp:
- 2010-10-25T16:38:14+02:00 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90
r2304 r2307 4 4 !! Fortran utilities: includes some low levels fortran functionality 5 5 !!====================================================================== 6 !! History : 3.2 ! 2010-05 Michael Dunphy, Rachid BENSHILA Original code 7 !!---------------------------------------------------------------------- 8 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 9 !! $Id$ 10 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 11 !!---------------------------------------------------------------------- 12 USE par_oce 13 USE par_kind 14 USE lib_mpp ! distributed memory computing 15 USE dom_oce 16 USE in_out_manager 6 !! History : 3.2 ! 2010-05 (M. Dunphy, R. Benshila) Original code 7 !!---------------------------------------------------------------------- 8 9 !!---------------------------------------------------------------------- 10 !! glob_sum : generic interface for global masked summation over 11 !! the interior domain for 1 or 2 2D or 3D arrays 12 !! it works only for T points 13 !! SIGN : generic interface for SIGN to overwrite f95 behaviour 14 !! of intrinsinc sign function 15 !!---------------------------------------------------------------------- 16 USE par_oce ! Ocean parameter 17 USE lib_mpp ! distributed memory computing 18 USE dom_oce ! ocean domain 19 USE in_out_manager ! I/O manager 17 20 18 21 IMPLICIT NONE … … 25 28 26 29 INTERFACE glob_sum 27 #if defined key_mpp_rep28 MODULE PROCEDURE mpp_sum_cmpx29 #else30 30 MODULE PROCEDURE glob_sum_2d, glob_sum_3d,glob_sum_2d_a, glob_sum_3d_a 31 #endif32 31 END INTERFACE 33 32 34 33 #if defined key_nosignedzeo 35 34 INTERFACE SIGN 36 MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D, &37 SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,&38 35 MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D, & 36 & SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A, & 37 & SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B 39 38 END INTERFACE 40 39 #endif 41 40 41 !!---------------------------------------------------------------------- 42 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 43 !! $Id$ 44 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 45 !!---------------------------------------------------------------------- 42 46 CONTAINS 43 47 44 FUNCTION glob_sum_2d( ptab ) 48 #if ! defined key_mpp_rep 49 FUNCTION glob_sum_2d( ptab ) RESULT( glob_sum ) 45 50 !!----------------------------------------------------------------------- 46 51 !! *** FUNCTION glob_sum_2D *** 47 52 !! 48 !! ** Purpose : perform a sum on theglobal domain of a 2D array49 !!----------------------------------------------------------------------- 50 REAL(wp), DIMENSION(:,:),INTENT(in) :: ptab51 REAL(wp) :: glob_sum_2d52 !!----------------------------------------------------------------------- 53 54 glob_sum _2d= SUM( ptab(:,:)*tmask_i(:,:) )55 IF( lk_mpp ) CALL mpp_sum( glob_sum _2d)56 53 !! ** Purpose : perform a masked sum on the inner global domain of a 2D array 54 !!----------------------------------------------------------------------- 55 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array 56 REAL(wp) :: glob_sum ! global masked sum 57 !!----------------------------------------------------------------------- 58 ! 59 glob_sum = SUM( ptab(:,:)*tmask_i(:,:) ) 60 IF( lk_mpp ) CALL mpp_sum( glob_sum ) 61 ! 57 62 END FUNCTION glob_sum_2d 58 59 FUNCTION glob_sum_3d( ptab ) 63 64 65 FUNCTION glob_sum_3d( ptab ) RESULT( glob_sum ) 60 66 !!----------------------------------------------------------------------- 61 67 !! *** FUNCTION glob_sum_3D *** 62 68 !! 63 !! ** Purpose : perform a sum on theglobal domain of a 3D array64 !!----------------------------------------------------------------------- 65 REAL(wp), DIMENSION(:,:,:) :: ptab66 REAL(wp) :: glob_sum_3d67 ! 69 !! ** Purpose : perform a masked sum on the inner global domain of a 3D array 70 !!----------------------------------------------------------------------- 71 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array 72 REAL(wp) :: glob_sum ! global masked sum 73 !! 68 74 INTEGER :: jk 69 75 !!----------------------------------------------------------------------- 70 71 GLOB_SUM_3D= 0.e076 ! 77 glob_sum = 0.e0 72 78 DO jk = 1, jpk 73 glob_sum _3d = glob_sum_3d+ SUM( ptab(:,:,jk)*tmask_i(:,:) )74 END DO 75 IF( lk_mpp ) CALL mpp_sum( glob_sum _3d)76 79 glob_sum = glob_sum + SUM( ptab(:,:,jk)*tmask_i(:,:) ) 80 END DO 81 IF( lk_mpp ) CALL mpp_sum( glob_sum ) 82 ! 77 83 END FUNCTION glob_sum_3d 78 84 79 FUNCTION glob_sum_2d_a( ptab1, ptab2 ) 85 86 FUNCTION glob_sum_2d_a( ptab1, ptab2 ) RESULT( glob_sum ) 80 87 !!----------------------------------------------------------------------- 81 88 !! *** FUNCTION glob_sum_2D _a *** 82 89 !! 83 !! ** Purpose : perform a sum on theglobal domain of two 2D array84 !!----------------------------------------------------------------------- 85 REAL(wp), DIMENSION(:,:) :: ptab1, ptab286 REAL(wp) , DIMENSION(2) :: glob_sum_2d_a87 !!----------------------------------------------------------------------- 88 89 glob_sum _2d_a(1) = SUM( ptab1(:,:)*tmask_i(:,:) )90 glob_sum _2d_a(2) = SUM( ptab2(:,:)*tmask_i(:,:) )91 IF( lk_mpp ) CALL mpp_sum( glob_sum _2d_a,2 )92 90 !! ** Purpose : perform a masked sum on the inner global domain of two 2D array 91 !!----------------------------------------------------------------------- 92 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 ! input 2D array 93 REAL(wp) , DIMENSION(2) :: glob_sum ! global masked sum 94 !!----------------------------------------------------------------------- 95 ! 96 glob_sum(1) = SUM( ptab1(:,:)*tmask_i(:,:) ) 97 glob_sum(2) = SUM( ptab2(:,:)*tmask_i(:,:) ) 98 IF( lk_mpp ) CALL mpp_sum( glob_sum, 2 ) 99 ! 93 100 END FUNCTION glob_sum_2d_a 94 101 95 FUNCTION glob_sum_3d_a( ptab1, ptab2 ) 102 103 FUNCTION glob_sum_3d_a( ptab1, ptab2 ) RESULT( glob_sum ) 96 104 !!----------------------------------------------------------------------- 97 105 !! *** FUNCTION glob_sum_3D_a *** 98 106 !! 99 !! ** Purpose : perform a sum on theglobal domain of two 3D array100 !!----------------------------------------------------------------------- 101 REAL(wp), DIMENSION(:,:,:) :: ptab1, ptab2102 REAL(wp) , DIMENSION(2) :: glob_sum_3d_a103 ! 107 !! ** Purpose : perform a masked sum on the inner global domain of two 3D array 108 !!----------------------------------------------------------------------- 109 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array 110 REAL(wp) , DIMENSION(2) :: glob_sum ! global masked sum 111 !! 104 112 INTEGER :: jk 105 113 !!----------------------------------------------------------------------- 106 107 glob_sum _3d_a(:) = 0.e0114 ! 115 glob_sum(:) = 0.e0 108 116 DO jk = 1, jpk 109 glob_sum _3d_a(1) = glob_sum_3d_a(1) + SUM( ptab1(:,:,jk)*tmask_i(:,:) )110 glob_sum _3d_a(2) = glob_sum_3d_a(2) + SUM( ptab2(:,:,jk)*tmask_i(:,:) )111 END DO 112 IF( lk_mpp ) CALL mpp_sum( glob_sum _3d_a,2 )113 117 glob_sum(1) = glob_sum(1) + SUM( ptab1(:,:,jk)*tmask_i(:,:) ) 118 glob_sum(2) = glob_sum(2) + SUM( ptab2(:,:,jk)*tmask_i(:,:) ) 119 END DO 120 IF( lk_mpp ) CALL mpp_sum( glob_sum, 2 ) 121 ! 114 122 END FUNCTION glob_sum_3d_a 115 123 116 #if defined key_mpp_rep 117 FUNCTION mpp_sum_cmpx( pval ) 118 !!---------------------------------------------------------------------- 119 !! *** FUNCTION mpp_sum_cmpx *** 124 #else 125 !!---------------------------------------------------------------------- 126 !! 'key_mpp_rep' MPP reproducibility 127 !!---------------------------------------------------------------------- 128 129 FUNCTION glob_sum_2d( ptab ) RESULT( glob_sum ) 130 !!---------------------------------------------------------------------- 131 !! *** FUNCTION glob_sum_2d *** 120 132 !! 121 133 !! ** Purpose : perform a sum in calling DDPDD routine 122 !! 123 !!---------------------------------------------------------------------- 124 REAL(wp) :: mpp_sum_cmpx 125 ! 126 REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: & 127 & pval 128 COMPLEX(wp):: ctmp 129 REAL(wp) ::ztmp 130 INTEGER :: ji,jj 131 !!----------------------------------------------------------------------- 132 134 !!---------------------------------------------------------------------- 135 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: ptab 136 REAL(wp) :: glob_sum ! global masked sum 137 !! 138 COMPLEX(wp):: ctmp 139 REAL(wp) :: ztmp 140 INTEGER :: ji, jj ! dummy loop indices 141 !!----------------------------------------------------------------------- 142 ! 133 143 ztmp = 0.e0 134 ctmp = CMPLX( 0.e0,0.e0,wp)135 DO jj = 1, jpj144 ctmp = CMPLX( 0.e0, 0.e0, wp ) 145 DO jj = 1, jpj 136 146 DO ji =1, jpi 137 ztmp = p val(ji,jj) * tmask_i(ji,jj)138 CALL DDPDD( CMPLX(ztmp,0.e0,wp),ctmp)147 ztmp = ptab(ji,jj) * tmask_i(ji,jj) 148 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 139 149 END DO 140 150 END DO 141 151 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 142 mpp_sum_cmpx= REAL(ctmp,wp) 143 144 END FUNCTION mpp_sum_cmpx 152 glob_sum = REAL(ctmp,wp) 153 ! 154 END FUNCTION glob_sum_2d 155 156 157 FUNCTION glob_sum_3d( ptab ) RESULT( glob_sum ) 158 !!---------------------------------------------------------------------- 159 !! *** FUNCTION glob_sum_3d *** 160 !! 161 !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine 162 !!---------------------------------------------------------------------- 163 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: ptab 164 REAL(wp) :: glob_sum ! global masked sum 165 !! 166 COMPLEX(wp):: ctmp 167 REAL(wp) :: ztmp 168 INTEGER :: ji, jj, jk ! dummy loop indices 169 !!----------------------------------------------------------------------- 170 ! 171 ztmp = 0.e0 172 ctmp = CMPLX( 0.e0, 0.e0, wp ) 173 DO jk = 1, jpk 174 DO jj = 1, jpj 175 DO ji =1, jpi 176 ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) 177 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 178 END DO 179 END DO 180 END DO 181 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 182 glob_sum = REAL(ctmp,wp) 183 ! 184 END FUNCTION glob_sum_3d 185 186 187 FUNCTION glob_sum_2d_a( ptab1, ptab2 ) RESULT( glob_sum ) 188 !!---------------------------------------------------------------------- 189 !! *** FUNCTION glob_sum_2d_a *** 190 !! 191 !! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine 192 !!---------------------------------------------------------------------- 193 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: ptab1, ptab2 194 REAL(wp) :: glob_sum ! global masked sum 195 !! 196 COMPLEX(wp):: ctmp 197 REAL(wp) :: ztmp 198 INTEGER :: ji, jj ! dummy loop indices 199 !!----------------------------------------------------------------------- 200 ! 201 ztmp = 0.e0 202 ctmp = CMPLX( 0.e0, 0.e0, wp ) 203 DO jj = 1, jpj 204 DO ji =1, jpi 205 ztmp = ptab1(ji,jj) * tmask_i(ji,jj) 206 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 207 ztmp = ptab2(ji,jj) * tmask_i(ji,jj) 208 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 209 END DO 210 END DO 211 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 212 glob_sum = REAL(ctmp,wp) 213 ! 214 END FUNCTION glob_sum_2d_a 215 216 217 FUNCTION glob_sum_3d_a( ptab1, ptab2 ) RESULT( glob_sum ) 218 !!---------------------------------------------------------------------- 219 !! *** FUNCTION glob_sum_3d_a *** 220 !! 221 !! ** Purpose : perform a sum on two 3D array in calling DDPDD routine 222 !!---------------------------------------------------------------------- 223 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: ptab1, ptab2 224 REAL(wp) :: glob_sum ! global masked sum 225 !! 226 COMPLEX(wp):: ctmp 227 REAL(wp) :: ztmp 228 INTEGER :: ji, jj, jk ! dummy loop indices 229 !!----------------------------------------------------------------------- 230 ! 231 ztmp = 0.e0 232 ctmp = CMPLX( 0.e0, 0.e0, wp ) 233 DO jk = 1, jpk 234 DO jj = 1, jpj 235 DO ji =1, jpi 236 ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj) 237 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 238 ztmp = ptab2(ji,jj,jk) * tmask_i(ji,jj) 239 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 240 END DO 241 END DO 242 END DO 243 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 244 glob_sum = REAL(ctmp,wp) 245 ! 246 END FUNCTION glob_sum_3d_a 247 145 248 146 249 SUBROUTINE DDPDD( ydda, yddb ) … … 159 262 !! References : Using Acurate Arithmetics to Improve Numerical 160 263 !! Reproducibility and Sability in Parallel Applications 161 !! Yun HE and Chris H. Q. DING, Journal of Supercomputing 162 !! 18, 259-277, 2001 163 !!---------------------------------------------------------------------- 164 165 COMPLEX(wp), INTENT(in) :: ydda 166 COMPLEX(wp), INTENT(inout) :: yddb 167 264 !! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001 265 !!---------------------------------------------------------------------- 266 COMPLEX(wp), INTENT(in ) :: ydda 267 COMPLEX(wp), INTENT(inout) :: yddb 268 ! 168 269 REAL(wp) :: zerr, zt1, zt2 ! local work variables 169 270 !!----------------------------------------------------------------------- 271 ! 170 272 ! Compute ydda + yddb using Knuth's trick. 171 zt1 = real(ydda) + real(yddb)172 zerr = zt1 - real(ydda)173 zt2 = ( (real(yddb) - zerr) + (real(ydda) - (zt1 - zerr)))&174 + aimag(ydda) + aimag(yddb)175 273 zt1 = REAL(ydda) + REAL(yddb) 274 zerr = zt1 - REAL(ydda) 275 zt2 = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) ) & 276 & + AIMAG(ydda) + AIMAG(yddb) 277 ! 176 278 ! The result is t1 + t2, after normalization. 177 yddb = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )178 279 yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp ) 280 ! 179 281 END SUBROUTINE DDPDD 180 282 #endif 181 283 182 284 #if defined key_nosignedzero 183 FUNCTION SIGN_SCALAR(pa,pb) 285 !!---------------------------------------------------------------------- 286 !! 'key_nosignedzero' F90 SIGN 287 !!---------------------------------------------------------------------- 288 289 FUNCTION SIGN_SCALAR( pa, pb ) 184 290 !!----------------------------------------------------------------------- 185 291 !! *** FUNCTION SIGN_SCALAR *** … … 188 294 !!----------------------------------------------------------------------- 189 295 REAL(wp) :: pa,pb ! input 190 REAL(wp) :: SIGN_SCALAR ! result 191 IF ( pb >= 0.e0) THEN 192 SIGN_SCALAR = ABS(pa) 193 ELSE 194 SIGN_SCALAR =-ABS(pa) 296 REAL(wp) :: SIGN_SCALAR ! result 297 !!----------------------------------------------------------------------- 298 IF ( pb >= 0.e0) THEN ; SIGN_SCALAR = ABS(pa) 299 ELSE ; SIGN_SCALAR =-ABS(pa) 195 300 ENDIF 196 197 301 END FUNCTION SIGN_SCALAR 198 302 199 FUNCTION SIGN_ARRAY_1D(pa,pb) 303 304 FUNCTION SIGN_ARRAY_1D( pa, pb ) 200 305 !!----------------------------------------------------------------------- 201 306 !! *** FUNCTION SIGN_ARRAY_1D *** … … 203 308 !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function 204 309 !!----------------------------------------------------------------------- 205 REAL(wp) :: pa,pb(:) ! input310 REAL(wp) :: pa,pb(:) ! input 206 311 REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1)) ! result 207 WHERE ( pb >= 0.e0 ) 208 SIGN_ARRAY_1D = ABS(pa) 209 ELSEWHERE 210 SIGN_ARRAY_1D =-ABS(pa) 211 END WHERE 212 312 !!----------------------------------------------------------------------- 313 WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D = ABS(pa) 314 ELSEWHERE ; SIGN_ARRAY_1D =-ABS(pa) 315 END WHERE 213 316 END FUNCTION SIGN_ARRAY_1D 317 214 318 215 319 FUNCTION SIGN_ARRAY_2D(pa,pb) … … 221 325 REAL(wp) :: pa,pb(:,:) ! input 222 326 REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2)) ! result 223 224 WHERE ( pb >= 0.e0 ) 225 SIGN_ARRAY_2D = ABS(pa) 226 ELSEWHERE 227 SIGN_ARRAY_2D =-ABS(pa) 228 END WHERE 229 327 !!----------------------------------------------------------------------- 328 WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D = ABS(pa) 329 ELSEWHERE ; SIGN_ARRAY_2D =-ABS(pa) 330 END WHERE 230 331 END FUNCTION SIGN_ARRAY_2D 231 332 … … 238 339 REAL(wp) :: pa,pb(:,:,:) ! input 239 340 REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result 240 WHERE ( pb >= 0.e0 ) 241 SIGN_ARRAY_3D = ABS(pa) 242 ELSEWHERE 243 SIGN_ARRAY_3D =-ABS(pa) 244 END WHERE 245 341 !!----------------------------------------------------------------------- 342 WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D = ABS(pa) 343 ELSEWHERE ; SIGN_ARRAY_3D =-ABS(pa) 344 END WHERE 246 345 END FUNCTION SIGN_ARRAY_3D 247 346 347 248 348 FUNCTION SIGN_ARRAY_1D_A(pa,pb) 249 349 !!----------------------------------------------------------------------- … … 253 353 !!----------------------------------------------------------------------- 254 354 REAL(wp) :: pa(:),pb(:) ! input 255 REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(b,1)) ! result 256 257 WHERE ( pb >= 0.e0 ) 258 SIGN_ARRAY_1D_A = ABS(pa) 259 ELSEWHERE 260 SIGN_ARRAY_1D_A =-ABS(pa) 261 END WHERE 262 355 REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1)) ! result 356 !!----------------------------------------------------------------------- 357 WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D_A = ABS(pa) 358 ELSEWHERE ; SIGN_ARRAY_1D_A =-ABS(pa) 359 END WHERE 263 360 END FUNCTION SIGN_ARRAY_1D_A 361 264 362 265 363 FUNCTION SIGN_ARRAY_2D_A(pa,pb) … … 271 369 REAL(wp) :: pa(:,:),pb(:,:) ! input 272 370 REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2)) ! result 273 274 WHERE ( pb >= 0.e0 ) 275 SIGN_ARRAY_2D_A = ABS(pa) 276 ELSEWHERE 277 SIGN_ARRAY_2D_A =-ABS(pa) 278 END WHERE 279 371 !!----------------------------------------------------------------------- 372 WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D_A = ABS(pa) 373 ELSEWHERE ; SIGN_ARRAY_2D_A =-ABS(pa) 374 END WHERE 280 375 END FUNCTION SIGN_ARRAY_2D_A 376 281 377 282 378 FUNCTION SIGN_ARRAY_3D_A(pa,pb) … … 288 384 REAL(wp) :: pa(:,:,:),pb(:,:,:) ! input 289 385 REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result 290 291 WHERE ( pb >= 0.e0 ) 292 SIGN_ARRAY_3D_A = ABS(pa) 293 ELSEWHERE 294 SIGN_ARRAY_3D_A =-ABS(pa) 295 END WHERE 296 386 !!----------------------------------------------------------------------- 387 WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D_A = ABS(pa) 388 ELSEWHERE ; SIGN_ARRAY_3D_A =-ABS(pa) 389 END WHERE 297 390 END FUNCTION SIGN_ARRAY_3D_A 391 298 392 299 393 FUNCTION SIGN_ARRAY_1D_B(pa,pb) … … 305 399 REAL(wp) :: pa(:),pb ! input 306 400 REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1)) ! result 307 308 IF ( pb >= 0.e0 ) THEN 309 SIGN_ARRAY_1D_B = ABS(pa) 310 ELSE 311 SIGN_ARRAY_1D_B =-ABS(pa) 401 !!----------------------------------------------------------------------- 402 IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_1D_B = ABS(pa) 403 ELSE ; SIGN_ARRAY_1D_B =-ABS(pa) 312 404 ENDIF 313 314 405 END FUNCTION SIGN_ARRAY_1D_B 406 315 407 316 408 FUNCTION SIGN_ARRAY_2D_B(pa,pb) … … 322 414 REAL(wp) :: pa(:,:),pb ! input 323 415 REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2)) ! result 324 325 IF ( pb >= 0.e0 ) THEN 326 SIGN_ARRAY_2D_B = ABS(pa) 327 ELSE 328 SIGN_ARRAY_2D_B =-ABS(pa) 416 !!----------------------------------------------------------------------- 417 IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_2D_B = ABS(pa) 418 ELSE ; SIGN_ARRAY_2D_B =-ABS(pa) 329 419 ENDIF 330 331 420 END FUNCTION SIGN_ARRAY_2D_B 421 332 422 333 423 FUNCTION SIGN_ARRAY_3D_B(pa,pb) … … 339 429 REAL(wp) :: pa(:,:,:),pb ! input 340 430 REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3)) ! result 341 342 IF (pb >= 0.e0 ) THEN 343 SIGN_ARRAY_3D_B = ABS(pa) 344 ELSE 345 SIGN_ARRAY_3D_B =-ABS(pa) 431 !!----------------------------------------------------------------------- 432 IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_3D_B = ABS(pa) 433 ELSE ; SIGN_ARRAY_3D_B =-ABS(pa) 346 434 ENDIF 347 348 435 END FUNCTION SIGN_ARRAY_3D_B 349 436 #endif 350 437 438 !!====================================================================== 351 439 END MODULE lib_fortran
Note: See TracChangeset
for help on using the changeset viewer.
