psmile_reduce.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE: PSMILe_Reduce_int
00008 !
00009 ! !INTERFACE:
00010 
00011     subroutine psmile_reduce_int ( task, shape_in, data_in, &
00012                           shape_out, data_out, mask, rdim, ierror )
00013 !
00014 ! !USES:
00015 !
00016       Use PSMILe, only : PSMILe_max, PSMILe_min, PSMILe_Integral, ch_id, len_cvs_string 
00017 
00018       Implicit None
00019 
00020 ! !INPUT PARAMETERS:
00021 
00022       Integer, Intent (In)  :: task
00023 
00024 !  Flag to determine operation to be performed
00025 
00026       Integer, Intent (In)  :: shape_in(2,6)
00027 
00028 !  Shape information of the input array
00029 
00030       Integer, Intent (In)  :: shape_out(2,5)
00031 
00032 !  Shape information of the output array
00033 
00034       Integer, Intent (In)  :: data_in ( shape_in(1,1) : shape_in (2,1), 
00035                                          shape_in(1,2) : shape_in (2,2), 
00036                                          shape_in(1,3) : shape_in (2,3), 
00037                                          shape_in(1,4) : shape_in (2,4), 
00038                                          shape_in(1,5) : shape_in (2,5), 
00039                                          shape_in(1,6) : shape_in (2,6) )
00040 !  Shape in input array
00041 
00042       Logical, Intent (In)  :: mask  ( shape_in(1,1) : shape_in (2,1), 
00043                                        shape_in(1,2) : shape_in (2,2), 
00044                                        shape_in(1,3) : shape_in (2,3), 
00045                                        shape_in(1,4) : shape_in (2,4), 
00046                                        shape_in(1,5) : shape_in (2,5) )
00047 !  Mask for input array
00048 
00049       Integer, Intent (In)  :: rdim
00050 
00051 !  Dimension over which reduction shall be done
00052 
00053 !
00054 ! !OUTPUT PARAMETERS:
00055 !
00056       Integer, Intent (Out) :: data_out ( shape_out(1,1) : shape_out (2,1), 
00057                                           shape_out(1,2) : shape_out (2,2), 
00058                                           shape_out(1,3) : shape_out (2,3), 
00059                                           shape_out(1,4) : shape_out (2,4), 
00060                                           shape_out(1,5) : shape_out (2,5) )
00061 !  Reduced array
00062 
00063       Integer, Intent (Out)                :: ierror
00064 
00065 !     Returns the error code of psmile_reduce_int;
00066 !             ierror = 0 : No error
00067 !             ierror > 0 : Severe error
00068 !
00069 ! !LOCAL VARIABLES
00070 !
00071       Integer :: i
00072 !
00073 ! !DESCRIPTION:
00074 !
00075 ! Subroutine "psmile_reduce_int" reduces over one or all spacial dimensions
00076 !           using Fortran90 intrinsic function maxval, minval or sum dependent
00077 !           of argument task. 
00078 !
00079 !           Note: Reduction over any 2 spatial dimensions or more than two dimension
00080 !                 a routine psmile_multi_reduce_int is provided. When tested on a
00081 !                 NEC SX the multi_reduce routine is almost as fast as the the reduce
00082 !                 routine when test for reduction of a 4d array over the first 3 (spatial)
00083 !                 dimensions. Maybe psmile_reduce_* routine are not needed.
00084 !
00085 !
00086 ! !REVISION HISTORY:
00087 !
00088 !   Date      Programmer   Description
00089 ! ----------  ----------   -----------
00090 ! 03.07.17    R. Redler    created
00091 !
00092 !EOP
00093 !----------------------------------------------------------------------
00094 !
00095 ! $Id: psmile_reduce.F90 2325 2010-04-21 15:00:07Z valcke $
00096 ! $Autor$
00097 !
00098    Character(len=len_cvs_string), save :: mycvs = 
00099        '$Id: psmile_reduce.F90 2325 2010-04-21 15:00:07Z valcke $'
00100 !
00101 !----------------------------------------------------------------------
00102 
00103 #ifdef VERBOSE
00104       print *, trim(ch_id), ': psmile_reduce_int: Start for rank', rdim
00105 
00106       call psmile_flushstd
00107 #endif /* VERBOSE */
00108 
00109       ierror = 0
00110 
00111       select case (task)
00112 
00113       case (PSMILe_max)
00114 
00115 ! ... initialize return data with lowest possible integer value
00116 
00117          data_out = -huge(i)
00118 
00119 ! ... case selection is neccessary for the stupid pgf compiler
00120 
00121          select case (rdim)
00122 
00123          case ( 0 )
00124 
00125             do i = 1, shape_in (2,6)
00126                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), MASK=mask)
00127             enddo
00128 
00129          case ( 1 )
00130 
00131             do i = 1, shape_in (2,6)
00132                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 1, MASK=mask)
00133             enddo
00134 
00135          case ( 2 )
00136 
00137             do i = 1, shape_in (2,6)
00138                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 2, MASK=mask)
00139             enddo
00140 
00141          case ( 3 )
00142 
00143             do i = 1, shape_in (2,6)
00144                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 3, MASK=mask)
00145             enddo
00146 
00147          case ( 4 )
00148 
00149             do i = 1, shape_in (2,6)
00150                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 4, MASK=mask)
00151             enddo
00152 
00153          case ( 5 )
00154 
00155             do i = 1, shape_in (2,6)
00156                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 5, MASK=mask)
00157             enddo
00158 
00159          case default
00160 
00161             print *, 'Unsupported dimension in reduce_int', rdim
00162 
00163             ierror = 999
00164 
00165          end select
00166 
00167       case (PSMILe_min)
00168 
00169 ! .... initialize return data with highest possible integer value
00170 
00171          data_out = huge(i)
00172 
00173 ! .... case selection for rdim is neccessary for the stupid pgf compiler
00174 
00175          select case (rdim)
00176 
00177          case ( 0 )
00178 
00179             do i = 1, shape_in (2,6)
00180                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), MASK=mask)
00181             enddo
00182 
00183          case ( 1 )
00184 
00185             do i = 1, shape_in (2,6)
00186                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 1, MASK=mask)
00187             enddo
00188 
00189          case ( 2 )
00190 
00191             do i = 1, shape_in (2,6)
00192                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 2, MASK=mask)
00193             enddo
00194 
00195          case ( 3 )
00196 
00197             do i = 1, shape_in (2,6)
00198                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 3, MASK=mask)
00199             enddo
00200 
00201          case ( 4 )
00202 
00203             do i = 1, shape_in (2,6)
00204                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 4, MASK=mask)
00205             enddo
00206 
00207          case ( 5 )
00208 
00209             do i = 1, shape_in (2,6)
00210                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 5, MASK=mask)
00211             enddo
00212 
00213          case default
00214 
00215             print *, 'Unsupported dimension in reduce_int', rdim
00216 
00217             ierror = 999
00218 
00219          end select ! rdim
00220 
00221       case (PSMILe_Integral)
00222 
00223 ! .... initialize return data with highest possible integer value
00224 
00225          data_out = 0
00226 
00227 ! .... case selection for rdim is neccessary for the stupid pgf compiler
00228 
00229          select case (rdim)
00230 
00231          case ( 0 )
00232 
00233             do i = 1, shape_in (2,6)
00234                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), MASK=mask)
00235             enddo
00236 
00237          case ( 1 )
00238 
00239             do i = 1, shape_in (2,6)
00240                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 1, MASK=mask)
00241             enddo
00242 
00243          case ( 2 )
00244 
00245             do i = 1, shape_in (2,6)
00246                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 2, MASK=mask)
00247             enddo
00248 
00249          case ( 3 )
00250 
00251             do i = 1, shape_in (2,6)
00252                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 3, MASK=mask)
00253             enddo
00254 
00255          case ( 4 )
00256 
00257             do i = 1, shape_in (2,6)
00258                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 4, MASK=mask)
00259             enddo
00260 
00261          case ( 5 )
00262 
00263             do i = 1, shape_in (2,6)
00264                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 5, MASK=mask)
00265             enddo
00266 
00267          case default
00268 
00269             print *, 'Unsupported dimension in reduce_real', rdim
00270 
00271             ierror = 999
00272 
00273          end select ! rdim
00274 
00275       end select ! task
00276 
00277 #ifdef VERBOSE
00278       print *, trim(ch_id), ': psmile_reduce_int: eof ierror ', ierror
00279 
00280       call psmile_flushstd
00281 #endif /* VERBOSE */
00282 
00283     End Subroutine psmile_reduce_int
00284 
00285 
00286 #ifndef PRISM_EXTENDED_WIDTH
00287 
00288 !-----------------------------------------------------------------------
00289 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00290 ! All rights reserved. Use is subject to OASIS4 license terms.
00291 !-----------------------------------------------------------------------
00292 !BOP
00293 !
00294 ! !ROUTINE: PSMILe_Reduce_real
00295 !
00296 ! !INTERFACE:
00297 
00298     subroutine psmile_reduce_real ( task, shape_in, data_in, &
00299                           shape_out, data_out, mask, rdim, ierror )
00300 !
00301 ! !USES:
00302 !
00303       Use PSMILe, only : PSMILe_max, PSMILe_min, PSMILe_Integral, ch_id, len_cvs_string
00304 
00305       Implicit None
00306 !
00307 ! !INPUT PARAMETERS:
00308 !
00309       Integer, Intent (In)  :: task
00310 
00311 !  Flag to determine operation to be performed
00312 
00313       Integer, Intent (In)  :: shape_in(2,6)
00314 
00315 !  Shape information of the input array
00316 
00317       Integer, Intent (In)  :: shape_out(2,5)
00318 
00319 !  Shape information of the output array
00320 
00321       Real, Intent (In)     :: data_in ( shape_in(1,1) : shape_in (2,1), 
00322                                          shape_in(1,2) : shape_in (2,2), 
00323                                          shape_in(1,3) : shape_in (2,3), 
00324                                          shape_in(1,4) : shape_in (2,4), 
00325                                          shape_in(1,5) : shape_in (2,5), 
00326                                          shape_in(1,6) : shape_in (2,6) )
00327 !  Shape in input array
00328 
00329       Logical, Intent (In)  :: mask  ( shape_in(1,1) : shape_in (2,1), 
00330                                        shape_in(1,2) : shape_in (2,2), 
00331                                        shape_in(1,3) : shape_in (2,3), 
00332                                        shape_in(1,4) : shape_in (2,4), 
00333                                        shape_in(1,5) : shape_in (2,5) )
00334 !  Mask for input array
00335 
00336       Integer, Intent (In)  :: rdim
00337 
00338 !  Dimension over which reduction shall be done
00339 !
00340 !
00341 ! !OUTPUT PARAMETERS:
00342 !
00343       Real, Intent (Out)    :: data_out ( shape_out(1,1) : shape_out (2,1), 
00344                                           shape_out(1,2) : shape_out (2,2), 
00345                                           shape_out(1,3) : shape_out (2,3), 
00346                                           shape_out(1,4) : shape_out (2,4), 
00347                                           shape_out(1,5) : shape_out (2,5) )
00348 !  Reduced array
00349 
00350       Integer, Intent (Out)                :: ierror
00351 
00352 !     Returns the error code of psmile_reduce_real;
00353 !             ierror = 0 : No error
00354 !             ierror > 0 : Severe error
00355 !
00356 ! !LOCAL VARIABLES
00357 !
00358       Integer :: i
00359 !
00360 ! !DESCRIPTION:
00361 !
00362 ! Subroutine "psmile_reduce_real" reduces over one or all spacial dimensions
00363 !           using Fortran90 intrinsic function maxval, minval or sum dependent
00364 !           of argument task. 
00365 !
00366 !
00367 ! !REVISION HISTORY:
00368 !
00369 !   Date      Programmer   Description
00370 ! ----------  ----------   -----------
00371 ! 03.07.17    R. Redler    created
00372 !
00373 !EOP
00374 !----------------------------------------------------------------------
00375 !
00376 ! $Id: psmile_reduce.F90 2325 2010-04-21 15:00:07Z valcke $
00377 ! $Autor$
00378 !
00379    Character(len=len_cvs_string), save :: mycvs = 
00380        '$Id: psmile_reduce.F90 2325 2010-04-21 15:00:07Z valcke $'
00381 !
00382 !----------------------------------------------------------------------
00383 
00384 #ifdef VERBOSE
00385       print *, trim(ch_id), ': psmile_reduce_real: Start for rank', rdim
00386 
00387       call psmile_flushstd
00388 #endif /* VERBOSE */
00389 
00390       ierror = 0
00391 
00392       select case (task)
00393 
00394       case (PSMILe_max)
00395 
00396 ! ... initialize return data with lowest possible integer value
00397 
00398          data_out = -huge(i)
00399 
00400 ! ... case selection is neccessary for the stupid pgf compiler
00401 
00402          select case (rdim)
00403 
00404          case ( 0 )
00405 
00406             do i = 1, shape_in (2,6)
00407                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), MASK=mask)
00408             enddo
00409 
00410          case ( 1 )
00411 
00412             do i = 1, shape_in (2,6)
00413                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 1, MASK=mask)
00414             enddo
00415 
00416          case ( 2 )
00417 
00418             do i = 1, shape_in (2,6)
00419                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 2, MASK=mask)
00420             enddo
00421 
00422          case ( 3 )
00423 
00424             do i = 1, shape_in (2,6)
00425                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 3, MASK=mask)
00426             enddo
00427 
00428          case ( 4 )
00429 
00430             do i = 1, shape_in (2,6)
00431                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 4, MASK=mask)
00432             enddo
00433 
00434          case ( 5 )
00435 
00436             do i = 1, shape_in (2,6)
00437                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 5, MASK=mask)
00438             enddo
00439 
00440          case default
00441 
00442             print *, 'Unsupported dimension in reduce_real', rdim
00443 
00444             ierror = 999
00445 
00446          end select
00447 
00448       case (PSMILe_min)
00449 
00450 ! .... initialize return data with highest possible integer value
00451 
00452          data_out = huge(i)
00453 
00454 ! .... case selection for rdim is neccessary for the stupid pgf compiler
00455 
00456          select case (rdim)
00457 
00458          case ( 0 )
00459 
00460             do i = 1, shape_in (2,6)
00461                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), MASK=mask)
00462             enddo
00463 
00464          case ( 1 )
00465 
00466             do i = 1, shape_in (2,6)
00467                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 1, MASK=mask)
00468             enddo
00469 
00470          case ( 2 )
00471 
00472             do i = 1, shape_in (2,6)
00473                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 2, MASK=mask)
00474             enddo
00475 
00476          case ( 3 )
00477 
00478             do i = 1, shape_in (2,6)
00479                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 3, MASK=mask)
00480             enddo
00481 
00482          case ( 4 )
00483 
00484             do i = 1, shape_in (2,6)
00485                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 4, MASK=mask)
00486             enddo
00487 
00488          case ( 5 )
00489 
00490             do i = 1, shape_in (2,6)
00491                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 5, MASK=mask)
00492             enddo
00493 
00494          case default
00495 
00496             print *, 'Unsupported dimension in reduce_real', rdim
00497 
00498             ierror = 999
00499 
00500          end select ! rdim
00501 
00502       case (PSMILe_Integral)
00503 
00504 ! .... initialize return data with highest possible integer value
00505 
00506          data_out = 0.0
00507 
00508 ! .... case selection for rdim is neccessary for the stupid pgf compiler
00509 
00510          select case (rdim)
00511 
00512          case ( 0 )
00513 
00514             do i = 1, shape_in (2,6)
00515                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), MASK=mask)
00516             enddo
00517 
00518          case ( 1 )
00519 
00520             do i = 1, shape_in (2,6)
00521                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 1, MASK=mask)
00522             enddo
00523 
00524          case ( 2 )
00525 
00526             do i = 1, shape_in (2,6)
00527                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 2, MASK=mask)
00528             enddo
00529 
00530          case ( 3 )
00531 
00532             do i = 1, shape_in (2,6)
00533                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 3, MASK=mask)
00534             enddo
00535 
00536          case ( 4 )
00537 
00538             do i = 1, shape_in (2,6)
00539                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 4, MASK=mask)
00540             enddo
00541 
00542          case ( 5 )
00543 
00544             do i = 1, shape_in (2,6)
00545                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 5, MASK=mask)
00546             enddo
00547 
00548          case default
00549 
00550             print *, 'Unsupported dimension in reduce_real', rdim
00551 
00552             ierror = 999
00553 
00554          end select ! rdim
00555 
00556       end select ! task
00557 
00558 #ifdef VERBOSE
00559       print *, trim(ch_id), ': psmile_reduce_real: eof ierror ', ierror
00560 
00561       call psmile_flushstd
00562 #endif /* VERBOSE */
00563 
00564     End Subroutine psmile_reduce_real
00565 
00566 #endif
00567 
00568 !-----------------------------------------------------------------------
00569 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00570 ! All rights reserved. Use is subject to OASIS4 license terms.
00571 !-----------------------------------------------------------------------
00572 !BOP
00573 !
00574 ! !ROUTINE: PSMILe_Reduce_dble
00575 !
00576 ! !INTERFACE:
00577 
00578     subroutine psmile_reduce_dble ( task, shape_in, data_in, &
00579                           shape_out, data_out, mask, rdim, ierror )
00580 !
00581 ! !USES:
00582 !
00583       Use PSMILe, only : PSMILe_max, PSMILe_min, PSMILe_Integral, ch_id, len_cvs_string
00584 
00585       Implicit None
00586 !
00587 ! !INPUT PARAMETERS:
00588 !
00589       Integer, Intent (In)  :: task
00590 
00591 !  Flag to determine operation to be performed
00592 
00593       Integer, Intent (In)  :: shape_in(2,6)
00594 
00595 !  Shape information of the input array
00596 
00597       Integer, Intent (In)  :: shape_out(2,5)
00598 
00599 !  Shape information of the output array
00600 
00601       Double Precision, Intent (In) :: data_in ( shape_in(1,1) : shape_in (2,1), 
00602                                                  shape_in(1,2) : shape_in (2,2), 
00603                                                  shape_in(1,3) : shape_in (2,3), 
00604                                                  shape_in(1,4) : shape_in (2,4), 
00605                                                  shape_in(1,5) : shape_in (2,5), 
00606                                                  shape_in(1,6) : shape_in (2,6) )
00607 !  Input array
00608 
00609       Logical, Intent (In)  :: mask  ( shape_in(1,1) : shape_in (2,1), 
00610                                        shape_in(1,2) : shape_in (2,2), 
00611                                        shape_in(1,3) : shape_in (2,3), 
00612                                        shape_in(1,4) : shape_in (2,4), 
00613                                        shape_in(1,5) : shape_in (2,5) )
00614 !  Mask for input array
00615 
00616       Integer, Intent (In)  :: rdim
00617 
00618 !  Dimension over which reduction shall be done
00619 !
00620 !
00621 ! !OUTPUT PARAMETERS:
00622 !
00623       Double Precision, Intent (Out) :: data_out ( shape_out(1,1) : shape_out (2,1), 
00624                                                    shape_out(1,2) : shape_out (2,2), 
00625                                                    shape_out(1,3) : shape_out (2,3), 
00626                                                    shape_out(1,4) : shape_out (2,4), 
00627                                                    shape_out(1,5) : shape_out (2,5) )
00628 !  Reduced array
00629 
00630       Integer, Intent (Out)                :: ierror
00631 
00632 !     Returns the error code of psmile_reduce_dble;
00633 !             ierror = 0 : No error
00634 !             ierror > 0 : Severe error
00635 !
00636 ! !LOCAL VARIABLES
00637 !
00638       Integer :: i
00639 !
00640 ! !DESCRIPTION:
00641 !
00642 ! Subroutine "psmile_reduce_dble" reduces over one or all spacial dimensions
00643 !           using Fortran90 intrinsic function maxval, minval or sum dependent
00644 !           of argument task. 
00645 !
00646 ! !REVISION HISTORY:
00647 !
00648 !   Date      Programmer   Description
00649 ! ----------  ----------   -----------
00650 ! 03.07.17    R. Redler    created
00651 !
00652 !EOP
00653 !----------------------------------------------------------------------
00654 !
00655 ! $Id: psmile_reduce.F90 2325 2010-04-21 15:00:07Z valcke $
00656 ! $Autor$
00657 !
00658    Character(len=len_cvs_string), save :: mycvs = 
00659        '$Id: psmile_reduce.F90 2325 2010-04-21 15:00:07Z valcke $'
00660 !
00661 !----------------------------------------------------------------------
00662 
00663 #ifdef VERBOSE
00664       print *, trim(ch_id), ': psmile_reduce_dble: Start for rank', rdim
00665 
00666       call psmile_flushstd
00667 #endif /* VERBOSE */
00668 
00669       ierror = 0
00670 
00671       select case (task)
00672 
00673       case (PSMILe_max)
00674 
00675 ! ... initialize return data with lowest possible integer value
00676 
00677          data_out = -huge(i)
00678 
00679 ! ... case selection is neccessary for the stupid pgf compiler
00680 
00681          select case (rdim)
00682 
00683          case ( 0 )
00684 
00685             do i = 1, shape_in (2,6)
00686                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), MASK=mask)
00687             enddo
00688 
00689          case ( 1 )
00690 
00691             do i = 1, shape_in (2,6)
00692                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 1, MASK=mask)
00693             enddo
00694 
00695          case ( 2 )
00696 
00697             do i = 1, shape_in (2,6)
00698                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 2, MASK=mask)
00699             enddo
00700 
00701          case ( 3 )
00702 
00703             do i = 1, shape_in (2,6)
00704                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 3, MASK=mask)
00705             enddo
00706 
00707          case ( 4 )
00708 
00709             do i = 1, shape_in (2,6)
00710                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 4, MASK=mask)
00711             enddo
00712 
00713          case ( 5 )
00714 
00715             do i = 1, shape_in (2,6)
00716                data_out(:,:,:,:,i) = maxval(data_in(:,:,:,:,:,i), 5, MASK=mask)
00717             enddo
00718 
00719          case default
00720 
00721             print *, 'Unsupported dimension in reduce_dble', rdim
00722 
00723             ierror = 999
00724 
00725          end select
00726 
00727       case (PSMILe_min)
00728 
00729 ! .... initialize return data with highest possible integer value
00730 
00731          data_out = huge(i)
00732 
00733 ! .... case selection for rdim is neccessary for the stupid pgf compiler
00734 
00735          select case (rdim)
00736 
00737          case ( 0 )
00738 
00739             do i = 1, shape_in (2,6)
00740                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), MASK=mask)
00741             enddo
00742 
00743          case ( 1 )
00744 
00745             do i = 1, shape_in (2,6)
00746                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 1, MASK=mask)
00747             enddo
00748 
00749          case ( 2 )
00750 
00751             do i = 1, shape_in (2,6)
00752                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 2, MASK=mask)
00753             enddo
00754 
00755          case ( 3 )
00756 
00757             do i = 1, shape_in (2,6)
00758                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 3, MASK=mask)
00759             enddo
00760 
00761          case ( 4 )
00762 
00763             do i = 1, shape_in (2,6)
00764                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 4, MASK=mask)
00765             enddo
00766 
00767          case ( 5 )
00768 
00769             do i = 1, shape_in (2,6)
00770                data_out(:,:,:,:,i) = minval(data_in(:,:,:,:,:,i), 5, MASK=mask)
00771             enddo
00772 
00773          case default
00774 
00775             print *, 'Unsupported dimension in reduce_dble', rdim
00776 
00777             ierror = 999
00778 
00779          end select ! rdim
00780 
00781       case (PSMILe_Integral)
00782 
00783 ! .... initialize return data with highest possible integer value
00784 
00785          data_out = 0.0
00786 
00787 ! .... case selection for rdim is neccessary for the stupid pgf compiler
00788 
00789          select case (rdim)
00790 
00791          case ( 0 )
00792 
00793             do i = 1, shape_in (2,6)
00794                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), MASK=mask)
00795             enddo
00796 
00797          case ( 1 )
00798 
00799             do i = 1, shape_in (2,6)
00800                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 1, MASK=mask)
00801             enddo
00802 
00803          case ( 2 )
00804 
00805             do i = 1, shape_in (2,6)
00806                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 2, MASK=mask)
00807             enddo
00808 
00809          case ( 3 )
00810 
00811             do i = 1, shape_in (2,6)
00812                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 3, MASK=mask)
00813             enddo
00814 
00815          case ( 4 )
00816 
00817             do i = 1, shape_in (2,6)
00818                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 4, MASK=mask)
00819             enddo
00820 
00821          case ( 5 )
00822 
00823             do i = 1, shape_in (2,6)
00824                data_out(:,:,:,:,i) = sum(data_in(:,:,:,:,:,i), 5, MASK=mask)
00825             enddo
00826 
00827          case default
00828 
00829             print *, 'Unsupported dimension in reduce_real', rdim
00830 
00831             ierror = 999
00832 
00833          end select ! rdim
00834 
00835       end select ! task
00836 
00837 #ifdef VERBOSE
00838       print *, trim(ch_id), ': psmile_reduce_dble: eof ierror ', ierror
00839 
00840       call psmile_flushstd
00841 #endif /* VERBOSE */
00842 
00843     End Subroutine psmile_reduce_dble
00844 
00845 
00846 !-----------------------------------------------------------------------
00847 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00848 ! All rights reserved. Use is subject to OASIS4 license terms.
00849 !-----------------------------------------------------------------------
00850 !BOP
00851 !
00852 ! !ROUTINE: PSMILe_Multi_reduce_int
00853 !
00854 ! !INTERFACE:
00855 
00856     subroutine psmile_multi_reduce_int ( task, shape_in, data_in, &
00857                                         shape_out, data_out, mask, ierror )
00858 !
00859 ! !USES:
00860 !
00861       Use PSMILe, only : PSMILe_max, PSMILe_min, PSMILe_Integral, ch_id, dummy_interface => PSMILe_Multi_reduce_int
00862 
00863       Implicit None
00864 !
00865 ! !INPUT PARAMETERS:
00866 !
00867       Integer, Intent (In)  :: task
00868 !
00869 !  Flag to determine operation to be performed
00870 !
00871       Integer, Intent (In)  :: shape_in(2,6)
00872 !
00873 !  Shape information of the input array
00874 !
00875       Integer, Intent (In)  :: shape_out(2,6)
00876 !
00877 !  Shape information of the output array
00878 !
00879       Integer, Intent (In)  :: data_in ( shape_in(1,1) : shape_in (2,1), 
00880                                          shape_in(1,2) : shape_in (2,2), 
00881                                          shape_in(1,3) : shape_in (2,3), 
00882                                          shape_in(1,4) : shape_in (2,4), 
00883                                          shape_in(1,5) : shape_in (2,5), 
00884                                          shape_in(1,6) : shape_in (2,6) )
00885 !
00886 !  Input array
00887 !
00888       Logical, Intent (In)  :: mask  ( shape_in(1,1) : shape_in (2,1), 
00889                                        shape_in(1,2) : shape_in (2,2), 
00890                                        shape_in(1,3) : shape_in (2,3), 
00891                                        shape_in(1,4) : shape_in (2,4), 
00892                                        shape_in(1,5) : shape_in (2,5) )
00893 !
00894 !  Mask for input array
00895 !
00896 !
00897 ! !OUTPUT PARAMETERS:
00898 !
00899       Integer, Intent (Out) :: data_out ( shape_out(1,1) : shape_out (2,1), 
00900                                           shape_out(1,2) : shape_out (2,2), 
00901                                           shape_out(1,3) : shape_out (2,3), 
00902                                           shape_out(1,4) : shape_out (2,4), 
00903                                           shape_out(1,5) : shape_out (2,5), 
00904                                           shape_out(1,6) : shape_out (2,6) )
00905 !
00906 !  Reduced array
00907 !
00908       Integer, Intent (Out)                :: ierror
00909 !
00910 !     Returns the error code of prism_get;
00911 !             ierror = 0 : No error
00912 !             ierror > 0 : Severe error
00913 !
00914 ! !DESCRIPTION:
00915 !
00916 ! Subroutine "psmile_multi_reduce_int" reduces over any one or more dimensions
00917 !             using Fortran90 intrinsic function max or min dependent of
00918 !             argument task. Summation is done by hand.
00919 !
00920 !
00921 ! !REVISION HISTORY:
00922 !   Date      Programmer   Description
00923 ! ----------  ----------   -----------
00924 ! 03.07.17    R. Redler    created
00925 !
00926 !EOP
00927 !----------------------------------------------------------------------
00928 ! $Id: psmile_reduce.F90 2325 2010-04-21 15:00:07Z valcke $
00929 ! $Autor$
00930 !----------------------------------------------------------------------
00931 !
00932 ! !LOCAL VARIABLES
00933 
00934       Integer :: i1,i2,i3,i4,i5,i6  ! loop indicees
00935       Integer ::    j2,j3,j4,j5,j6  ! element pointer
00936 
00937       Integer :: j(6)               ! flag 0/1
00938 !
00939 !----------------------------------------------------------------------
00940 
00941 #ifdef VERBOSE
00942       print *, trim(ch_id), ': psmile_multi_reduce_int: Start'
00943 
00944       call psmile_flushstd
00945 #endif /* VERBOSE */
00946 
00947       ierror = 0
00948 
00949       select case (task)
00950 
00951       case (PSMILe_max)
00952          !
00953          ! ... find maximum along two or more selected dimensions using
00954          !     Fortran 90 intrinsic function max.
00955          !
00956          ! .... initialize return data with lowest possible integer value
00957          !
00958          data_out = -huge(i1)
00959          !
00960          ! .... determine ranks of the input array that have to be reduced.
00961          !      They are marked with j(rank) = .true. which is later used
00962          !      to fix the element index for the output array in the loop.
00963          !
00964          j = 1
00965          do i1 = 1, 5
00966             if ( shape_out(1,i1) == shape_out(2,i1) ) j(i1) = 0
00967          enddo
00968 
00969          do i6 = shape_in(1,6), shape_in(2,6)
00970             j6=i6
00971             do i5 = shape_in(1,5), shape_in(2,5)
00972                j5 = 1 + j(5) * ( i5 - 1 )
00973                do i4 = shape_in(1,4), shape_in(2,4)
00974                   j4 = 1 + j(4) * ( i4 - 1 )
00975                   do i3 = shape_in(1,3), shape_in(2,3)
00976                      j3 = 1 + j(3) * ( i3 - 1 )
00977                      do i2 = shape_in(1,2), shape_in(2,2)
00978                         j2 = 1 + j(2) * ( i2 - 1 )
00979 
00980                         if ( j(1) == 0 ) then
00981                            do i1 = shape_in(1,1), shape_in(2,1)
00982                               if ( mask(i1,i2,i3,i4,i5)) &
00983                                    data_out(1,j2,j3,j4,j5,j6) = &
00984                                    max(data_out(1,j2,j3,j4,j5,j6), data_in(i1,i2,i3,i4,i5,i6))
00985                            enddo
00986                         else
00987                            do i1 = shape_in(1,1), shape_in(2,1)
00988                               if ( mask(i1,i2,i3,i4,i5)) &
00989                                    data_out(i1,j2,j3,j4,j5,j6) = &
00990                                    max(data_out(i1,j2,j3,j4,j5,j6),data_in(i1,i2,i3,i4,i5,i6))
00991                            enddo
00992                         endif
00993 
00994                      enddo
00995                   enddo
00996                enddo
00997             enddo
00998          enddo
00999 
01000       case (PSMILe_min)
01001          !
01002          ! ... find maximum along two or more selected dimensions using
01003          !     Fortran 90 intrinsic function max.
01004          !
01005          ! .... initialize return data with lowest possible integer value
01006          !
01007          data_out = huge(i1)
01008          !
01009          ! .... determine ranks of the input array that have to be reduced.
01010          !      They are marked with j(rank) = .true. which is later used
01011          !      to fix the element index for the output array in the loop.
01012          !
01013          j = 1
01014          do i1 = 1, 5
01015             if ( shape_out(1,i1) == shape_out(2,i1) ) j(i1) = 0
01016          enddo
01017 
01018          do i6 = shape_in(1,6), shape_in(2,6)
01019             j6=i6
01020             do i5 = shape_in(1,5), shape_in(2,5)
01021                j5 = 1 + j(5) * ( i5 - 1 )
01022                do i4 = shape_in(1,4), shape_in(2,4)
01023                   j4 = 1 + j(4) * ( i4 - 1 )
01024                   do i3 = shape_in(1,3), shape_in(2,3)
01025                      j3 = 1 + j(3) * ( i3 - 1 )
01026                      do i2 = shape_in(1,2), shape_in(2,2)
01027                         j2 = 1 + j(2) * ( i2 - 1 )
01028 
01029                         if ( j(1) == 0 ) then
01030                            do i1 = shape_in(1,1), shape_in(2,1)
01031                               if ( mask(i1,i2,i3,i4,i5)) &
01032                                    data_out(1,j2,j3,j4,j5,j6) = &
01033                                    min(data_out(1,j2,j3,j4,j5,j6), data_in(i1,i2,i3,i4,i5,i6))
01034                            enddo
01035                         else
01036                            do i1 = shape_in(1,1), shape_in(2,1)
01037                               if ( mask(i1,i2,i3,i4,i5)) &
01038                                    data_out(i1,j2,j3,j4,j5,j6) = &
01039                                    min(data_out(i1,j2,j3,j4,j5,j6),data_in(i1,i2,i3,i4,i5,i6))
01040                            enddo
01041                         endif
01042 
01043                      enddo
01044                   enddo
01045                enddo
01046             enddo
01047          enddo
01048 
01049       case (PSMILe_Integral)
01050          !
01051          ! ... sum up along two or more selected dimensions
01052          !
01053          ! .... initialize return data 
01054          !
01055          data_out = 0
01056          !
01057          ! .... determine ranks of the input array that have to be reduced.
01058          !      They are marked with j(rank) = .true. which is later used
01059          !      to fix the element index for the output array in the loop.
01060          !
01061          j = 1
01062          do i1 = 1, 5
01063             if ( shape_out(1,i1) == shape_out(2,i1) ) j(i1) = 0
01064          enddo
01065 
01066          do i6 = shape_in(1,6), shape_in(2,6)
01067             j6=i6
01068             do i5 = shape_in(1,5), shape_in(2,5)
01069                j5 = 1 + j(5) * ( i5 - 1 )
01070                do i4 = shape_in(1,4), shape_in(2,4)
01071                   j4 = 1 + j(4) * ( i4 - 1 )
01072                   do i3 = shape_in(1,3), shape_in(2,3)
01073                      j3 = 1 + j(3) * ( i3 - 1 )
01074                      do i2 = shape_in(1,2), shape_in(2,2)
01075                         j2 = 1 + j(2) * ( i2 - 1 )
01076 
01077                         if ( j(1) == 0 ) then
01078                            do i1 = shape_in(1,1), shape_in(2,1)
01079                               if ( mask(i1,i2,i3,i4,i5)) &
01080                                    data_out(1,j2,j3,j4,j5,j6) = &
01081                                    data_out(1,j2,j3,j4,j5,j6) + data_in(i1,i2,i3,i4,i5,i6)
01082                            enddo
01083                         else
01084                            do i1 = shape_in(1,1), shape_in(2,1)
01085                               if ( mask(i1,i2,i3,i4,i5)) &
01086                                    data_out(i1,j2,j3,j4,j5,j6) = &
01087                                    data_out(i1,j2,j3,j4,j5,j6) + data_in(i1,i2,i3,i4,i5,i6)
01088                            enddo
01089                         endif
01090 
01091                      enddo
01092                   enddo
01093                enddo
01094             enddo
01095          enddo
01096 
01097       end select ! task
01098 
01099 #ifdef VERBOSE
01100       print *, trim(ch_id), ': psmile_multi_reduce_int: eof ierror ', ierror
01101 
01102       call psmile_flushstd
01103 #endif /* VERBOSE */
01104 
01105     End Subroutine psmile_multi_reduce_int
01106 
01107 #ifndef PRISM_EXTENDED_WIDTH
01108 
01109 !-----------------------------------------------------------------------
01110 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
01111 ! All rights reserved. Use is subject to OASIS4 license terms.
01112 !-----------------------------------------------------------------------
01113 !BOP
01114 !
01115 ! !ROUTINE: PSMILe_Multi_reduce_real
01116 !
01117 ! !INTERFACE:
01118 
01119     subroutine psmile_multi_reduce_real ( task, shape_in, data_in, &
01120                                         shape_out, data_out, mask, ierror )
01121 !
01122 ! !USES:
01123 !
01124       Use PSMILe, only : PSMILe_max, PSMILe_min, PSMILe_Integral, ch_id, dummy_interface => PSMILe_Multi_reduce_real
01125 
01126       Implicit None
01127 !
01128 ! !INPUT PARAMETERS:
01129 !
01130       Integer, Intent (In)  :: task
01131 !
01132 !  Flag to determine operation to be performed
01133 !
01134       Integer, Intent (In)  :: shape_in(2,6)
01135 !
01136 !  Shape information of the input array
01137 !
01138       Integer, Intent (In)  :: shape_out(2,6)
01139 !
01140 !  Shape information of the output array
01141 !
01142       Real, Intent (In)  :: data_in ( shape_in(1,1) : shape_in (2,1), 
01143                                       shape_in(1,2) : shape_in (2,2), 
01144                                       shape_in(1,3) : shape_in (2,3), 
01145                                       shape_in(1,4) : shape_in (2,4), 
01146                                       shape_in(1,5) : shape_in (2,5), 
01147                                       shape_in(1,6) : shape_in (2,6) )
01148 !
01149 !  Input array
01150 !
01151       Logical, Intent (In)  :: mask  ( shape_in(1,1) : shape_in (2,1), 
01152                                        shape_in(1,2) : shape_in (2,2), 
01153                                        shape_in(1,3) : shape_in (2,3), 
01154                                        shape_in(1,4) : shape_in (2,4), 
01155                                        shape_in(1,5) : shape_in (2,5) )
01156 !
01157 !  Mask for input array
01158 !
01159 !
01160 ! !OUTPUT PARAMETERS:
01161 !
01162       Real, Intent (Out) :: data_out ( shape_out(1,1) : shape_out (2,1), 
01163                                        shape_out(1,2) : shape_out (2,2), 
01164                                        shape_out(1,3) : shape_out (2,3), 
01165                                        shape_out(1,4) : shape_out (2,4), 
01166                                        shape_out(1,5) : shape_out (2,5), 
01167                                        shape_out(1,6) : shape_out (2,6) )
01168 !
01169 !  Reduced array
01170 !
01171       Integer, Intent (Out)                :: ierror
01172 !
01173 !     Returns the error code of prism_get;
01174 !             ierror = 0 : No error
01175 !             ierror > 0 : Severe error
01176 !
01177 ! !DESCRIPTION:
01178 !
01179 ! Subroutine "psmile_multi_reduce_real" reduces over any one or more dimensions
01180 !             using Fortran90 intrinsic function max or min dependent of
01181 !             argument task. 
01182 !
01183 !
01184 ! !REVISION HISTORY:
01185 !   Date      Programmer   Description
01186 ! ----------  ----------   -----------
01187 ! 03.07.17    R. Redler    created
01188 !
01189 !EOP
01190 !----------------------------------------------------------------------
01191 ! $Id: psmile_reduce.F90 2325 2010-04-21 15:00:07Z valcke $
01192 ! $Autor$
01193 !----------------------------------------------------------------------
01194 !
01195 ! !LOCAL VARIABLES
01196 
01197       Integer :: i1,i2,i3,i4,i5,i6  ! loop indicees
01198       Integer ::    j2,j3,j4,j5,j6  ! element pointer
01199 
01200       Integer :: j(6)               ! flag 0/1
01201       Real    :: rvar
01202 !
01203 !----------------------------------------------------------------------
01204 
01205 #ifdef VERBOSE
01206       print *, trim(ch_id), ': psmile_multi_reduce_real: Start'
01207 
01208       call psmile_flushstd
01209 #endif /* VERBOSE */
01210 
01211       ierror = 0
01212 
01213       select case (task)
01214 
01215       case (PSMILe_max)
01216          !
01217          ! ... find maximum along two or more selected dimensions using
01218          !     Fortran 90 intrinsic function max.
01219          !
01220          ! .... initialize return data with lowest possible integer value
01221          !
01222          data_out = -huge(rvar)
01223          !
01224          ! .... determine ranks of the input array that have to be reduced.
01225          !      They are marked with j(rank) = .true. which is later used
01226          !      to fix the element index for the output array in the loop.
01227          !
01228          j = 1
01229          do i1 = 1, 5
01230             if ( shape_out(1,i1) == shape_out(2,i1) ) j(i1) = 0
01231          enddo
01232 
01233          do i6 = shape_in(1,6), shape_in(2,6)
01234             j6=i6
01235             do i5 = shape_in(1,5), shape_in(2,5)
01236                j5 = 1 + j(5) * ( i5 - 1 )
01237                do i4 = shape_in(1,4), shape_in(2,4)
01238                   j4 = 1 + j(4) * ( i4 - 1 )
01239                   do i3 = shape_in(1,3), shape_in(2,3)
01240                      j3 = 1 + j(3) * ( i3 - 1 )
01241                      do i2 = shape_in(1,2), shape_in(2,2)
01242                         j2 = 1 + j(2) * ( i2 - 1 )
01243 
01244                         if ( j(1) == 0 ) then
01245                            do i1 = shape_in(1,1), shape_in(2,1)
01246                               if ( mask(i1,i2,i3,i4,i5)) &
01247                                    data_out(1,j2,j3,j4,j5,j6) = &
01248                                    max(data_out(1,j2,j3,j4,j5,j6), data_in(i1,i2,i3,i4,i5,i6))
01249                            enddo
01250                         else
01251                            do i1 = shape_in(1,1), shape_in(2,1)
01252                               if ( mask(i1,i2,i3,i4,i5)) &
01253                                    data_out(i1,j2,j3,j4,j5,j6) = &
01254                                    max(data_out(i1,j2,j3,j4,j5,j6),data_in(i1,i2,i3,i4,i5,i6))
01255                            enddo
01256                         endif
01257 
01258                      enddo
01259                   enddo
01260                enddo
01261             enddo
01262          enddo
01263 
01264       case (PSMILe_min)
01265          !
01266          ! ... find maximum along two or more selected dimensions using
01267          !     Fortran 90 intrinsic function max.
01268          !
01269          ! .... initialize return data with lowest possible integer value
01270          !
01271          data_out = huge(rvar)
01272          !
01273          ! .... determine ranks of the input array that have to be reduced.
01274          !      They are marked with j(rank) = .true. which is later used
01275          !      to fix the element index for the output array in the loop.
01276          !
01277          j = 1
01278          do i1 = 1, 5
01279             if ( shape_out(1,i1) == shape_out(2,i1) ) j(i1) = 0
01280          enddo
01281 
01282          do i6 = shape_in(1,6), shape_in(2,6)
01283             j6=i6
01284             do i5 = shape_in(1,5), shape_in(2,5)
01285                j5 = 1 + j(5) * ( i5 - 1 )
01286                do i4 = shape_in(1,4), shape_in(2,4)
01287                   j4 = 1 + j(4) * ( i4 - 1 )
01288                   do i3 = shape_in(1,3), shape_in(2,3)
01289                      j3 = 1 + j(3) * ( i3 - 1 )
01290                      do i2 = shape_in(1,2), shape_in(2,2)
01291                         j2 = 1 + j(2) * ( i2 - 1 )
01292 
01293                         if ( j(1) == 0 ) then
01294                            do i1 = shape_in(1,1), shape_in(2,1)
01295                               if ( mask(i1,i2,i3,i4,i5)) &
01296                                    data_out(1,j2,j3,j4,j5,j6) = &
01297                                    min(data_out(1,j2,j3,j4,j5,j6), data_in(i1,i2,i3,i4,i5,i6))
01298                            enddo
01299                         else
01300                            do i1 = shape_in(1,1), shape_in(2,1)
01301                               if ( mask(i1,i2,i3,i4,i5)) &
01302                                    data_out(i1,j2,j3,j4,j5,j6) = &
01303                                    min(data_out(i1,j2,j3,j4,j5,j6),data_in(i1,i2,i3,i4,i5,i6))
01304                            enddo
01305                         endif
01306 
01307                      enddo
01308                   enddo
01309                enddo
01310             enddo
01311          enddo
01312 
01313       case (PSMILe_Integral)
01314          !
01315          ! ... sum up along two or more selected dimensions
01316          !
01317          ! .... initialize return data 
01318          !
01319          data_out = 0.0
01320          !
01321          ! .... determine ranks of the input array that have to be reduced.
01322          !      They are marked with j(rank) = .true. which is later used
01323          !      to fix the element index for the output array in the loop.
01324          !
01325          j = 1
01326          do i1 = 1, 5
01327             if ( shape_out(1,i1) == shape_out(2,i1) ) j(i1) = 0
01328          enddo
01329 
01330          do i6 = shape_in(1,6), shape_in(2,6)
01331             j6=i6
01332             do i5 = shape_in(1,5), shape_in(2,5)
01333                j5 = 1 + j(5) * ( i5 - 1 )
01334                do i4 = shape_in(1,4), shape_in(2,4)
01335                   j4 = 1 + j(4) * ( i4 - 1 )
01336                   do i3 = shape_in(1,3), shape_in(2,3)
01337                      j3 = 1 + j(3) * ( i3 - 1 )
01338                      do i2 = shape_in(1,2), shape_in(2,2)
01339                         j2 = 1 + j(2) * ( i2 - 1 )
01340 
01341                         if ( j(1) == 0 ) then
01342                            do i1 = shape_in(1,1), shape_in(2,1)
01343                               if ( mask(i1,i2,i3,i4,i5)) &
01344                                    data_out(1,j2,j3,j4,j5,j6) = &
01345                                    data_out(1,j2,j3,j4,j5,j6) + data_in(i1,i2,i3,i4,i5,i6)
01346                            enddo
01347                         else
01348                            do i1 = shape_in(1,1), shape_in(2,1)
01349                               if ( mask(i1,i2,i3,i4,i5)) &
01350                                    data_out(i1,j2,j3,j4,j5,j6) = &
01351                                    data_out(i1,j2,j3,j4,j5,j6) + data_in(i1,i2,i3,i4,i5,i6)
01352                            enddo
01353                         endif
01354 
01355                      enddo
01356                   enddo
01357                enddo
01358             enddo
01359          enddo
01360 
01361       end select ! task
01362 
01363 #ifdef VERBOSE
01364       print *, trim(ch_id), ': psmile_multi_reduce_real: eof ierror ', ierror
01365 
01366       call psmile_flushstd
01367 #endif /* VERBOSE */
01368 
01369     End Subroutine psmile_multi_reduce_real
01370 
01371 #endif
01372 
01373 !-----------------------------------------------------------------------
01374 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
01375 ! All rights reserved. Use is subject to OASIS4 license terms.
01376 !-----------------------------------------------------------------------
01377 !BOP
01378 !
01379 ! !ROUTINE: PSMILe_Multi_reduce_dble
01380 !
01381 ! !INTERFACE:
01382 
01383     subroutine psmile_multi_reduce_dble ( task, shape_in, data_in, &
01384                                         shape_out, data_out, mask, ierror )
01385 !
01386 ! !USES:
01387 !
01388       Use PSMILe, only : PSMILe_max, PSMILe_min, PSMILe_Integral, ch_id, dummy_interface => PSMILe_Multi_reduce_dble
01389 
01390       Implicit None
01391 !
01392 ! !INPUT PARAMETERS:
01393 !
01394       Integer, Intent (In)  :: task
01395 !
01396 !  Flag to determine operation to be performed
01397 !
01398       Integer, Intent (In)  :: shape_in(2,6)
01399 !
01400 !  Shape information of the input array
01401 !
01402       Integer, Intent (In)  :: shape_out(2,6)
01403 !
01404 !  Shape information of the output array
01405 !
01406       Double Precision, Intent (In)  :: data_in ( shape_in(1,1) : shape_in (2,1), 
01407                                                   shape_in(1,2) : shape_in (2,2), 
01408                                                   shape_in(1,3) : shape_in (2,3), 
01409                                                   shape_in(1,4) : shape_in (2,4), 
01410                                                   shape_in(1,5) : shape_in (2,5), 
01411                                                   shape_in(1,6) : shape_in (2,6) )
01412 !
01413 !  Input array
01414 !
01415       Logical, Intent (In)  :: mask  ( shape_in(1,1) : shape_in (2,1), 
01416                                        shape_in(1,2) : shape_in (2,2), 
01417                                        shape_in(1,3) : shape_in (2,3), 
01418                                        shape_in(1,4) : shape_in (2,4), 
01419                                        shape_in(1,5) : shape_in (2,5) )
01420 !
01421 !  Mask for input array
01422 !
01423 !
01424 ! !OUTPUT PARAMETERS:
01425 !
01426       Double Precision, Intent (Out) :: data_out ( shape_out(1,1) : shape_out (2,1), 
01427                                                    shape_out(1,2) : shape_out (2,2), 
01428                                                    shape_out(1,3) : shape_out (2,3), 
01429                                                    shape_out(1,4) : shape_out (2,4), 
01430                                                    shape_out(1,5) : shape_out (2,5), 
01431                                                    shape_out(1,6) : shape_out (2,6) )
01432 !
01433 !  Reduced array
01434 !
01435       Integer, Intent (Out)                :: ierror
01436 !
01437 !     Returns the error code of prism_get;
01438 !             ierror = 0 : No error
01439 !             ierror > 0 : Severe error
01440 !
01441 ! !DESCRIPTION:
01442 !
01443 ! Subroutine "psmile_multi_reduce_dble" reduces over any one or more dimensions
01444 !             using Fortran90 intrinsic function max or min dependent of
01445 !             argument task. 
01446 !
01447 !
01448 ! !REVISION HISTORY:
01449 !   Date      Programmer   Description
01450 ! ----------  ----------   -----------
01451 ! 03.07.17    R. Redler    created
01452 !
01453 !EOP
01454 !----------------------------------------------------------------------
01455 ! $Id: psmile_reduce.F90 2325 2010-04-21 15:00:07Z valcke $
01456 ! $Autor$
01457 !----------------------------------------------------------------------
01458 !
01459 ! !LOCAL VARIABLES
01460 
01461       Integer :: i1,i2,i3,i4,i5,i6  ! loop indicees
01462       Integer ::    j2,j3,j4,j5,j6  ! element pointer
01463 
01464       Integer :: j(6)               ! flag 0/1
01465 
01466       Double Precision :: dvar
01467 !
01468 !----------------------------------------------------------------------
01469 
01470 #ifdef VERBOSE
01471       print *, trim(ch_id), ': psmile_multi_reduce_dble: Start'
01472 
01473       call psmile_flushstd
01474 #endif /* VERBOSE */
01475 
01476       ierror = 0
01477 
01478       select case (task)
01479 
01480       case (PSMILe_max)
01481          !
01482          ! ... find maximum along two or more selected dimensions using
01483          !     Fortran 90 intrinsic function max.
01484          !
01485          ! .... initialize return data with lowest possible integer value
01486          !
01487          data_out = -huge(dvar)
01488          !
01489          ! .... determine ranks of the input array that have to be reduced.
01490          !      They are marked with j(rank) = .true. which is later used
01491          !      to fix the element index for the output array in the loop.
01492          !
01493          j = 1
01494          do i1 = 1, 5
01495             if ( shape_out(1,i1) == shape_out(2,i1) ) j(i1) = 0
01496          enddo
01497 
01498          do i6 = shape_in(1,6), shape_in(2,6)
01499             j6=i6
01500             do i5 = shape_in(1,5), shape_in(2,5)
01501                j5 = 1 + j(5) * ( i5 - 1 )
01502                do i4 = shape_in(1,4), shape_in(2,4)
01503                   j4 = 1 + j(4) * ( i4 - 1 )
01504                   do i3 = shape_in(1,3), shape_in(2,3)
01505                      j3 = 1 + j(3) * ( i3 - 1 )
01506                      do i2 = shape_in(1,2), shape_in(2,2)
01507                         j2 = 1 + j(2) * ( i2 - 1 )
01508 
01509                         if ( j(1) == 0 ) then
01510                            do i1 = shape_in(1,1), shape_in(2,1)
01511                               if ( mask(i1,i2,i3,i4,i5)) &
01512                                    data_out(1,j2,j3,j4,j5,j6) = &
01513                                    max(data_out(1,j2,j3,j4,j5,j6), data_in(i1,i2,i3,i4,i5,i6))
01514                            enddo
01515                         else
01516                            do i1 = shape_in(1,1), shape_in(2,1)
01517                               if ( mask(i1,i2,i3,i4,i5)) &
01518                                    data_out(i1,j2,j3,j4,j5,j6) = &
01519                                    max(data_out(i1,j2,j3,j4,j5,j6),data_in(i1,i2,i3,i4,i5,i6))
01520                            enddo
01521                         endif
01522 
01523                      enddo
01524                   enddo
01525                enddo
01526             enddo
01527          enddo
01528 
01529       case (PSMILe_min)
01530          !
01531          ! ... find maximum along two or more selected dimensions using
01532          !     Fortran 90 intrinsic function max.
01533          !
01534          ! .... initialize return data with lowest possible integer value
01535          !
01536          data_out = huge(dvar)
01537          !
01538          ! .... determine ranks of the input array that have to be reduced.
01539          !      They are marked with j(rank) = .true. which is later used
01540          !      to fix the element index for the output array in the loop.
01541          !
01542          j = 1
01543          do i1 = 1, 5
01544             if ( shape_out(1,i1) == shape_out(2,i1) ) j(i1) = 0
01545          enddo
01546 
01547          do i6 = shape_in(1,6), shape_in(2,6)
01548             j6=i6
01549             do i5 = shape_in(1,5), shape_in(2,5)
01550                j5 = 1 + j(5) * ( i5 - 1 )
01551                do i4 = shape_in(1,4), shape_in(2,4)
01552                   j4 = 1 + j(4) * ( i4 - 1 )
01553                   do i3 = shape_in(1,3), shape_in(2,3)
01554                      j3 = 1 + j(3) * ( i3 - 1 )
01555                      do i2 = shape_in(1,2), shape_in(2,2)
01556                         j2 = 1 + j(2) * ( i2 - 1 )
01557 
01558                         if ( j(1) == 0 ) then
01559                            do i1 = shape_in(1,1), shape_in(2,1)
01560                               if ( mask(i1,i2,i3,i4,i5)) &
01561                                    data_out(1,j2,j3,j4,j5,j6) = &
01562                                    min(data_out(1,j2,j3,j4,j5,j6), data_in(i1,i2,i3,i4,i5,i6))
01563                            enddo
01564                         else
01565                            do i1 = shape_in(1,1), shape_in(2,1)
01566                               if ( mask(i1,i2,i3,i4,i5)) &
01567                                    data_out(i1,j2,j3,j4,j5,j6) = &
01568                                    min(data_out(i1,j2,j3,j4,j5,j6),data_in(i1,i2,i3,i4,i5,i6))
01569                            enddo
01570                         endif
01571 
01572                      enddo
01573                   enddo
01574                enddo
01575             enddo
01576          enddo
01577 
01578       case (PSMILe_Integral)
01579          !
01580          ! ... sum up along two or more selected dimensions
01581          !
01582          ! .... initialize return data 
01583          !
01584          data_out = 0.0
01585          !
01586          ! .... determine ranks of the input array that have to be reduced.
01587          !      They are marked with j(rank) = .true. which is later used
01588          !      to fix the element index for the output array in the loop.
01589          !
01590          j = 1
01591          do i1 = 1, 5
01592             if ( shape_out(1,i1) == shape_out(2,i1) ) j(i1) = 0
01593          enddo
01594 
01595          do i6 = shape_in(1,6), shape_in(2,6)
01596             j6=i6
01597             do i5 = shape_in(1,5), shape_in(2,5)
01598                j5 = 1 + j(5) * ( i5 - 1 )
01599                do i4 = shape_in(1,4), shape_in(2,4)
01600                   j4 = 1 + j(4) * ( i4 - 1 )
01601                   do i3 = shape_in(1,3), shape_in(2,3)
01602                      j3 = 1 + j(3) * ( i3 - 1 )
01603                      do i2 = shape_in(1,2), shape_in(2,2)
01604                         j2 = 1 + j(2) * ( i2 - 1 )
01605 
01606                         if ( j(1) == 0 ) then
01607                            do i1 = shape_in(1,1), shape_in(2,1)
01608                               if ( mask(i1,i2,i3,i4,i5)) &
01609                                    data_out( 1,j2,j3,j4,j5,j6) = &
01610                                    data_out( 1,j2,j3,j4,j5,j6) + data_in(i1,i2,i3,i4,i5,i6)
01611                            enddo
01612                         else
01613                            do i1 = shape_in(1,1), shape_in(2,1)
01614                               if ( mask(i1,i2,i3,i4,i5)) &
01615                                    data_out(i1,j2,j3,j4,j5,j6) = &
01616                                    data_out(i1,j2,j3,j4,j5,j6) + data_in(i1,i2,i3,i4,i5,i6)
01617                            enddo
01618                         endif
01619 
01620                      enddo
01621                   enddo
01622                enddo
01623             enddo
01624          enddo
01625 
01626       end select ! task
01627 
01628 #ifdef VERBOSE
01629       print *, trim(ch_id), ': psmile_multi_reduce_dble: eof ierror ', ierror
01630 
01631       call psmile_flushstd
01632 #endif /* VERBOSE */
01633 
01634     End Subroutine psmile_multi_reduce_dble
01635
Generated on 18 Mar 2011 for Oasis4 by  doxygen 1.6.1