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.
Changeset 13226 for NEMO/trunk/src/OCE/LBC – NEMO

Ignore:
Timestamp:
2020-07-02T16:24:31+02:00 (4 years ago)
Author:
orioltp
Message:

Merging dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation into the trunk

Location:
NEMO/trunk/src/OCE/LBC
Files:
11 edited
2 copied

Legend:

Unmodified
Added
Removed

  • NEMO/trunk/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r11536 r13226  
    1 #if defined DIM_2d 
    2 #   define ARRAY_TYPE(i,j,k,l)   REAL(wp), DIMENSION(i,j) 
    3 #   define PTR_TYPE              TYPE(PTR_2D) 
    4 #   define PTR_ptab              pt2d 
    5 #endif 
    6 #if defined DIM_3d 
    7 #   define ARRAY_TYPE(i,j,k,l)   REAL(wp), DIMENSION(i,j,k) 
    8 #   define PTR_TYPE              TYPE(PTR_3D) 
    9 #   define PTR_ptab              pt3d 
    10 #endif 
    11 #if defined DIM_4d 
    12 #   define ARRAY_TYPE(i,j,k,l)   REAL(wp), DIMENSION(i,j,k,l) 
    13 #   define PTR_TYPE              TYPE(PTR_4D) 
    14 #   define PTR_ptab              pt4d 
     1#if defined SINGLE_PRECISION 
     2#   if defined DIM_2d 
     3#      define ARRAY_TYPE(i,j,k,l)   REAL(sp), DIMENSION(i,j) 
     4#      define PTR_TYPE              TYPE(PTR_2D_sp) 
     5#      define PTR_ptab              pt2d 
     6#   endif 
     7#   if defined DIM_3d 
     8#      define ARRAY_TYPE(i,j,k,l)   REAL(sp), DIMENSION(i,j,k) 
     9#      define PTR_TYPE              TYPE(PTR_3D_sp) 
     10#      define PTR_ptab              pt3d 
     11#   endif 
     12#   if defined DIM_4d 
     13#      define ARRAY_TYPE(i,j,k,l)   REAL(sp), DIMENSION(i,j,k,l) 
     14#      define PTR_TYPE              TYPE(PTR_4D_sp) 
     15#      define PTR_ptab              pt4d 
     16#   endif 
     17#   define PRECISION sp 
     18#else 
     19#   if defined DIM_2d 
     20#      define ARRAY_TYPE(i,j,k,l)   REAL(dp), DIMENSION(i,j) 
     21#      define PTR_TYPE              TYPE(PTR_2D_dp) 
     22#      define PTR_ptab              pt2d 
     23#   endif 
     24#   if defined DIM_3d 
     25#      define ARRAY_TYPE(i,j,k,l)   REAL(dp), DIMENSION(i,j,k) 
     26#      define PTR_TYPE              TYPE(PTR_3D_dp) 
     27#      define PTR_ptab              pt3d 
     28#   endif 
     29#   if defined DIM_4d 
     30#      define ARRAY_TYPE(i,j,k,l)   REAL(dp), DIMENSION(i,j,k,l) 
     31#      define PTR_TYPE              TYPE(PTR_4D_dp) 
     32#      define PTR_ptab              pt4d 
     33#   endif 
     34#   define PRECISION dp 
    1535#endif 
    1636 
    … …  
    7999   END SUBROUTINE ROUTINE_LOAD 
    80100 
     101#undef PRECISION 
    81102#undef ARRAY_TYPE 
    82103#undef PTR_TYPE 

  • NEMO/trunk/src/OCE/LBC/lbc_nfd_ext_generic.h90

    r10525 r13226  
    88#   define L_SIZE(ptab)          1 
    99#endif 
    10 #define ARRAY_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     10#if defined SINGLE_PRECISION 
     11#   define ARRAY_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     12#   define PRECISION sp 
     13#else 
     14#   define ARRAY_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     15#   define PRECISION dp 
     16#endif 
    1117 
    1218   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj ) 
    … …  
    149155   END SUBROUTINE ROUTINE_NFD 
    150156 
     157#undef PRECISION 
    151158#undef ARRAY_TYPE 
    152159#undef ARRAY_IN 

  • NEMO/trunk/src/OCE/LBC/lbc_nfd_generic.h90

    r10425 r13226  
    44#   define F_SIZE(ptab)             kfld 
    55#   if defined DIM_2d 
    6 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D),INTENT(inout)::ptab(f) 
     6#      if defined SINGLE_PRECISION 
     7#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 
     8#      else 
     9#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 
     10#      endif 
    711#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    812#      define K_SIZE(ptab)             1 
    … …  
    1014#   endif 
    1115#   if defined DIM_3d 
    12 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D),INTENT(inout)::ptab(f) 
     16#      if defined SINGLE_PRECISION 
     17#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 
     18#      else 
     19#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 
     20#      endif 
    1321#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    1422#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    … …  
    1624#   endif 
    1725#   if defined DIM_4d 
    18 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D),INTENT(inout)::ptab(f) 
     26#      if defined SINGLE_PRECISION 
     27#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 
     28#      else 
     29#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 
     30#      endif 
    1931#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    2032#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    … …  
    4153#      define L_SIZE(ptab)          SIZE(ptab,4) 
    4254#   endif 
    43 #   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     55#   if defined SINGLE_PRECISION 
     56#      define ARRAY_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     57#   else 
     58#      define ARRAY_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     59#   endif 
    4460#endif 
     61 
     62#   if defined SINGLE_PRECISION 
     63#      define PRECISION sp 
     64#   else 
     65#      define PRECISION dp 
     66#   endif 
    4567 
    4668#if defined MULTI 
    … …  
    167189   END SUBROUTINE ROUTINE_NFD 
    168190 
     191#undef PRECISION 
    169192#undef ARRAY_TYPE 
    170193#undef ARRAY_IN 

  • NEMO/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r11536 r13226  
    44#   define F_SIZE(ptab)             kfld 
    55#   if defined DIM_2d 
    6 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D),INTENT(inout)::ptab(f) 
     6#      if defined SINGLE_PRECISION 
     7#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 
     8#      else 
     9#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 
     10#      endif  
    711#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    812#      define K_SIZE(ptab)             1 
    … …  
    1014#   endif 
    1115#   if defined DIM_3d 
    12 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D),INTENT(inout)::ptab(f) 
     16#      if defined SINGLE_PRECISION 
     17#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 
     18#      else 
     19#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 
     20#      endif  
    1321#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    1422#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    … …  
    1624#   endif 
    1725#   if defined DIM_4d 
    18 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D),INTENT(inout)::ptab(f) 
     26#      if defined SINGLE_PRECISION 
     27#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 
     28#      else 
     29#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 
     30#      endif  
    1931#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    2032#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    2133#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4) 
    2234#   endif 
    23 #   define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D),INTENT(inout)::ptab2(f) 
     35#   if defined SINGLE_PRECISION 
     36#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f) 
     37#   else 
     38#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f) 
     39#   endif 
    2440#   define J_SIZE(ptab2)            SIZE(ptab2(1)%pt4d,2) 
    2541#   define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt4d(i,j,k,l) 
    … …  
    4662#   define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k,l) 
    4763#   define J_SIZE(ptab2)             SIZE(ptab2,2) 
    48 #   define ARRAY_TYPE(i,j,k,l,f)     REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    49 #   define ARRAY2_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
    50 #endif 
    51  
     64#   if defined SINGLE_PRECISION 
     65#      define ARRAY_TYPE(i,j,k,l,f)     REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     66#      define ARRAY2_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
     67#   else 
     68#      define ARRAY_TYPE(i,j,k,l,f)     REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     69#      define ARRAY2_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
     70#   endif 
     71#   endif 
     72#   ifdef SINGLE_PRECISION 
     73#      define PRECISION sp 
     74#   else 
     75#      define PRECISION dp 
     76#   endif 
    5277   SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) 
    5378      !!---------------------------------------------------------------------- 
    … …  
    345370      END DO            ! End jf loop 
    346371   END SUBROUTINE ROUTINE_NFD 
     372#undef PRECISION 
    347373#undef ARRAY_TYPE 
    348374#undef ARRAY_IN 

  • NEMO/trunk/src/OCE/LBC/lbclnk.F90

    r12377 r13226  
    2828 
    2929   INTERFACE lbc_lnk 
    30       MODULE PROCEDURE   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
     30      MODULE PROCEDURE   mpp_lnk_2d_sp   , mpp_lnk_3d_sp   , mpp_lnk_4d_sp 
     31      MODULE PROCEDURE   mpp_lnk_2d_dp   , mpp_lnk_3d_dp   , mpp_lnk_4d_dp 
    3132   END INTERFACE 
    3233   INTERFACE lbc_lnk_ptr 
    33       MODULE PROCEDURE   mpp_lnk_2d_ptr  , mpp_lnk_3d_ptr  , mpp_lnk_4d_ptr 
     34      MODULE PROCEDURE   mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp 
     35      MODULE PROCEDURE   mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp 
    3436   END INTERFACE 
    3537   INTERFACE lbc_lnk_multi 
    36       MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
     38      MODULE PROCEDURE   lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp 
     39      MODULE PROCEDURE   lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 
    3740   END INTERFACE 
    3841   ! 
    3942   INTERFACE lbc_lnk_icb 
    40       MODULE PROCEDURE mpp_lnk_2d_icb 
     43      MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp 
    4144   END INTERFACE 
    4245 
    4346   INTERFACE mpp_nfd 
    44       MODULE PROCEDURE   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
    45       MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     47      MODULE PROCEDURE   mpp_nfd_2d_sp    , mpp_nfd_3d_sp    , mpp_nfd_4d_sp 
     48      MODULE PROCEDURE   mpp_nfd_2d_dp    , mpp_nfd_3d_dp    , mpp_nfd_4d_dp 
     49      MODULE PROCEDURE   mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp 
     50      MODULE PROCEDURE   mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp 
     51       
    4652   END INTERFACE 
    4753 
    … …  
    9298   !!---------------------------------------------------------------------- 
    9399 
    94 #  define DIM_2d 
    95 #     define ROUTINE_LOAD           load_ptr_2d 
    96 #     define ROUTINE_MULTI          lbc_lnk_2d_multi 
    97 #     include "lbc_lnk_multi_generic.h90" 
    98 #     undef ROUTINE_MULTI 
    99 #     undef ROUTINE_LOAD 
    100 #  undef DIM_2d 
    101  
    102 #  define DIM_3d 
    103 #     define ROUTINE_LOAD           load_ptr_3d 
    104 #     define ROUTINE_MULTI          lbc_lnk_3d_multi 
    105 #     include "lbc_lnk_multi_generic.h90" 
    106 #     undef ROUTINE_MULTI 
    107 #     undef ROUTINE_LOAD 
    108 #  undef DIM_3d 
    109  
    110 #  define DIM_4d 
    111 #     define ROUTINE_LOAD           load_ptr_4d 
    112 #     define ROUTINE_MULTI          lbc_lnk_4d_multi 
     100   !! 
     101   !!   ----   SINGLE PRECISION VERSIONS 
     102   !! 
     103#  define SINGLE_PRECISION 
     104#  define DIM_2d 
     105#     define ROUTINE_LOAD           load_ptr_2d_sp 
     106#     define ROUTINE_MULTI          lbc_lnk_2d_multi_sp 
     107#     include "lbc_lnk_multi_generic.h90" 
     108#     undef ROUTINE_MULTI 
     109#     undef ROUTINE_LOAD 
     110#  undef DIM_2d 
     111 
     112#  define DIM_3d 
     113#     define ROUTINE_LOAD           load_ptr_3d_sp 
     114#     define ROUTINE_MULTI          lbc_lnk_3d_multi_sp 
     115#     include "lbc_lnk_multi_generic.h90" 
     116#     undef ROUTINE_MULTI 
     117#     undef ROUTINE_LOAD 
     118#  undef DIM_3d 
     119 
     120#  define DIM_4d 
     121#     define ROUTINE_LOAD           load_ptr_4d_sp 
     122#     define ROUTINE_MULTI          lbc_lnk_4d_multi_sp 
     123#     include "lbc_lnk_multi_generic.h90" 
     124#     undef ROUTINE_MULTI 
     125#     undef ROUTINE_LOAD 
     126#  undef DIM_4d 
     127#  undef SINGLE_PRECISION 
     128   !! 
     129   !!   ----   DOUBLE PRECISION VERSIONS 
     130   !! 
     131 
     132#  define DIM_2d 
     133#     define ROUTINE_LOAD           load_ptr_2d_dp 
     134#     define ROUTINE_MULTI          lbc_lnk_2d_multi_dp 
     135#     include "lbc_lnk_multi_generic.h90" 
     136#     undef ROUTINE_MULTI 
     137#     undef ROUTINE_LOAD 
     138#  undef DIM_2d 
     139 
     140#  define DIM_3d 
     141#     define ROUTINE_LOAD           load_ptr_3d_dp 
     142#     define ROUTINE_MULTI          lbc_lnk_3d_multi_dp 
     143#     include "lbc_lnk_multi_generic.h90" 
     144#     undef ROUTINE_MULTI 
     145#     undef ROUTINE_LOAD 
     146#  undef DIM_3d 
     147 
     148#  define DIM_4d 
     149#     define ROUTINE_LOAD           load_ptr_4d_dp 
     150#     define ROUTINE_MULTI          lbc_lnk_4d_multi_dp 
    113151#     include "lbc_lnk_multi_generic.h90" 
    114152#     undef ROUTINE_MULTI 
    … …  
    130168   !                       !==  2D array and array of 2D pointer  ==! 
    131169   ! 
    132 #  define DIM_2d 
    133 #     define ROUTINE_LNK           mpp_lnk_2d 
    134 #     include "mpp_lnk_generic.h90" 
    135 #     undef ROUTINE_LNK 
    136 #     define MULTI 
    137 #     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     170   !! 
     171   !!   ----   SINGLE PRECISION VERSIONS 
     172   !! 
     173# define SINGLE_PRECISION 
     174#  define DIM_2d 
     175#     define ROUTINE_LNK           mpp_lnk_2d_sp 
     176#     include "mpp_lnk_generic.h90" 
     177#     undef ROUTINE_LNK 
     178#     define MULTI 
     179#     define ROUTINE_LNK           mpp_lnk_2d_ptr_sp 
    138180#     include "mpp_lnk_generic.h90" 
    139181#     undef ROUTINE_LNK 
    … …  
    144186   ! 
    145187#  define DIM_3d 
    146 #     define ROUTINE_LNK           mpp_lnk_3d 
    147 #     include "mpp_lnk_generic.h90" 
    148 #     undef ROUTINE_LNK 
    149 #     define MULTI 
    150 #     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     188#     define ROUTINE_LNK           mpp_lnk_3d_sp 
     189#     include "mpp_lnk_generic.h90" 
     190#     undef ROUTINE_LNK 
     191#     define MULTI 
     192#     define ROUTINE_LNK           mpp_lnk_3d_ptr_sp 
    151193#     include "mpp_lnk_generic.h90" 
    152194#     undef ROUTINE_LNK 
    … …  
    157199   ! 
    158200#  define DIM_4d 
    159 #     define ROUTINE_LNK           mpp_lnk_4d 
    160 #     include "mpp_lnk_generic.h90" 
    161 #     undef ROUTINE_LNK 
    162 #     define MULTI 
    163 #     define ROUTINE_LNK           mpp_lnk_4d_ptr 
    164 #     include "mpp_lnk_generic.h90" 
    165 #     undef ROUTINE_LNK 
    166 #     undef MULTI 
    167 #  undef DIM_4d 
     201#     define ROUTINE_LNK           mpp_lnk_4d_sp 
     202#     include "mpp_lnk_generic.h90" 
     203#     undef ROUTINE_LNK 
     204#     define MULTI 
     205#     define ROUTINE_LNK           mpp_lnk_4d_ptr_sp 
     206#     include "mpp_lnk_generic.h90" 
     207#     undef ROUTINE_LNK 
     208#     undef MULTI 
     209#  undef DIM_4d 
     210# undef SINGLE_PRECISION 
     211 
     212   !! 
     213   !!   ----   DOUBLE PRECISION VERSIONS 
     214   !! 
     215#  define DIM_2d 
     216#     define ROUTINE_LNK           mpp_lnk_2d_dp 
     217#     include "mpp_lnk_generic.h90" 
     218#     undef ROUTINE_LNK 
     219#     define MULTI 
     220#     define ROUTINE_LNK           mpp_lnk_2d_ptr_dp 
     221#     include "mpp_lnk_generic.h90" 
     222#     undef ROUTINE_LNK 
     223#     undef MULTI 
     224#  undef DIM_2d 
     225   ! 
     226   !                       !==  3D array and array of 3D pointer  ==! 
     227   ! 
     228#  define DIM_3d 
     229#     define ROUTINE_LNK           mpp_lnk_3d_dp 
     230#     include "mpp_lnk_generic.h90" 
     231#     undef ROUTINE_LNK 
     232#     define MULTI 
     233#     define ROUTINE_LNK           mpp_lnk_3d_ptr_dp 
     234#     include "mpp_lnk_generic.h90" 
     235#     undef ROUTINE_LNK 
     236#     undef MULTI 
     237#  undef DIM_3d 
     238   ! 
     239   !                       !==  4D array and array of 4D pointer  ==! 
     240   ! 
     241#  define DIM_4d 
     242#     define ROUTINE_LNK           mpp_lnk_4d_dp 
     243#     include "mpp_lnk_generic.h90" 
     244#     undef ROUTINE_LNK 
     245#     define MULTI 
     246#     define ROUTINE_LNK           mpp_lnk_4d_ptr_dp 
     247#     include "mpp_lnk_generic.h90" 
     248#     undef ROUTINE_LNK 
     249#     undef MULTI 
     250#  undef DIM_4d 
     251 
    168252 
    169253   !!---------------------------------------------------------------------- 
    … …  
    181265   !                       !==  2D array and array of 2D pointer  ==! 
    182266   ! 
    183 #  define DIM_2d 
    184 #     define ROUTINE_NFD           mpp_nfd_2d 
    185 #     include "mpp_nfd_generic.h90" 
    186 #     undef ROUTINE_NFD 
    187 #     define MULTI 
    188 #     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     267   !! 
     268   !!   ----   SINGLE PRECISION VERSIONS 
     269   !! 
     270#  define SINGLE_PRECISION 
     271#  define DIM_2d 
     272#     define ROUTINE_NFD           mpp_nfd_2d_sp 
     273#     include "mpp_nfd_generic.h90" 
     274#     undef ROUTINE_NFD 
     275#     define MULTI 
     276#     define ROUTINE_NFD           mpp_nfd_2d_ptr_sp 
    189277#     include "mpp_nfd_generic.h90" 
    190278#     undef ROUTINE_NFD 
    … …  
    195283   ! 
    196284#  define DIM_3d 
    197 #     define ROUTINE_NFD           mpp_nfd_3d 
    198 #     include "mpp_nfd_generic.h90" 
    199 #     undef ROUTINE_NFD 
    200 #     define MULTI 
    201 #     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     285#     define ROUTINE_NFD           mpp_nfd_3d_sp 
     286#     include "mpp_nfd_generic.h90" 
     287#     undef ROUTINE_NFD 
     288#     define MULTI 
     289#     define ROUTINE_NFD           mpp_nfd_3d_ptr_sp 
    202290#     include "mpp_nfd_generic.h90" 
    203291#     undef ROUTINE_NFD 
    … …  
    208296   ! 
    209297#  define DIM_4d 
    210 #     define ROUTINE_NFD           mpp_nfd_4d 
    211 #     include "mpp_nfd_generic.h90" 
    212 #     undef ROUTINE_NFD 
    213 #     define MULTI 
    214 #     define ROUTINE_NFD           mpp_nfd_4d_ptr 
    215 #     include "mpp_nfd_generic.h90" 
    216 #     undef ROUTINE_NFD 
    217 #     undef MULTI 
    218 #  undef DIM_4d 
    219  
     298#     define ROUTINE_NFD           mpp_nfd_4d_sp 
     299#     include "mpp_nfd_generic.h90" 
     300#     undef ROUTINE_NFD 
     301#     define MULTI 
     302#     define ROUTINE_NFD           mpp_nfd_4d_ptr_sp 
     303#     include "mpp_nfd_generic.h90" 
     304#     undef ROUTINE_NFD 
     305#     undef MULTI 
     306#  undef DIM_4d 
     307#  undef SINGLE_PRECISION 
     308 
     309   !! 
     310   !!   ----   DOUBLE PRECISION VERSIONS 
     311   !! 
     312#  define DIM_2d 
     313#     define ROUTINE_NFD           mpp_nfd_2d_dp 
     314#     include "mpp_nfd_generic.h90" 
     315#     undef ROUTINE_NFD 
     316#     define MULTI 
     317#     define ROUTINE_NFD           mpp_nfd_2d_ptr_dp 
     318#     include "mpp_nfd_generic.h90" 
     319#     undef ROUTINE_NFD 
     320#     undef MULTI 
     321#  undef DIM_2d 
     322   ! 
     323   !                       !==  3D array and array of 3D pointer  ==! 
     324   ! 
     325#  define DIM_3d 
     326#     define ROUTINE_NFD           mpp_nfd_3d_dp 
     327#     include "mpp_nfd_generic.h90" 
     328#     undef ROUTINE_NFD 
     329#     define MULTI 
     330#     define ROUTINE_NFD           mpp_nfd_3d_ptr_dp 
     331#     include "mpp_nfd_generic.h90" 
     332#     undef ROUTINE_NFD 
     333#     undef MULTI 
     334#  undef DIM_3d 
     335   ! 
     336   !                       !==  4D array and array of 4D pointer  ==! 
     337   ! 
     338#  define DIM_4d 
     339#     define ROUTINE_NFD           mpp_nfd_4d_dp 
     340#     include "mpp_nfd_generic.h90" 
     341#     undef ROUTINE_NFD 
     342#     define MULTI 
     343#     define ROUTINE_NFD           mpp_nfd_4d_ptr_dp 
     344#     include "mpp_nfd_generic.h90" 
     345#     undef ROUTINE_NFD 
     346#     undef MULTI 
     347#  undef DIM_4d 
    220348 
    221349   !!====================================================================== 
    222350 
    223351 
    224  
    225    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    226       !!--------------------------------------------------------------------- 
     352   !!====================================================================== 
     353     !!--------------------------------------------------------------------- 
    227354      !!                   ***  routine mpp_lbc_north_icb  *** 
    228355      !! 
    … …  
    240367      !! 
    241368      !!---------------------------------------------------------------------- 
    242       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    243       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    244       !                                                     !   = T ,  U , V , F or W -points 
    245       REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    246       !!                                                    ! north fold, =  1. otherwise 
    247       INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    248       ! 
    249       INTEGER ::   ji, jj, jr 
    250       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    251       INTEGER ::   ipj, ij, iproc 
    252       ! 
    253       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    254       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    255       !!---------------------------------------------------------------------- 
    256 #if defined key_mpp_mpi 
    257       ! 
    258       ipj=4 
    259       ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
    260      &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
    261      &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
    262       ! 
    263       ztab_e(:,:)      = 0._wp 
    264       znorthloc_e(:,:) = 0._wp 
    265       ! 
    266       ij = 1 - kextj 
    267       ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
    268       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    269          znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    270          ij = ij + 1 
    271       END DO 
    272       ! 
    273       itaille = jpimax * ( ipj + 2*kextj ) 
    274       ! 
    275       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    276       CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
    277          &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
    278          &                ncomm_north, ierr ) 
    279       ! 
    280       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    281       ! 
    282       DO jr = 1, ndim_rank_north            ! recover the global north array 
    283          iproc = nrank_north(jr) + 1 
    284          ildi = nldit (iproc) 
    285          ilei = nleit (iproc) 
    286          iilb = nimppt(iproc) 
    287          DO jj = 1-kextj, ipj+kextj 
    288             DO ji = ildi, ilei 
    289                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    290             END DO 
    291          END DO 
    292       END DO 
    293  
    294       ! 2. North-Fold boundary conditions 
    295       ! ---------------------------------- 
    296       CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
    297  
    298       ij = 1 - kextj 
    299       !! Scatter back to pt2d 
    300       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    301          DO ji= 1, jpi 
    302             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    303          END DO 
    304          ij  = ij +1 
    305       END DO 
    306       ! 
    307       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    308       ! 
    309 #endif 
    310    END SUBROUTINE mpp_lbc_north_icb 
    311  
    312  
    313    SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
     369#     define SINGLE_PRECISION 
     370#     define ROUTINE_LNK           mpp_lbc_north_icb_sp 
     371#     include "mpp_lbc_north_icb_generic.h90" 
     372#     undef ROUTINE_LNK 
     373#     undef SINGLE_PRECISION 
     374#     define ROUTINE_LNK           mpp_lbc_north_icb_dp 
     375#     include "mpp_lbc_north_icb_generic.h90" 
     376#     undef ROUTINE_LNK 
     377  
     378 
    314379      !!---------------------------------------------------------------------- 
    315380      !!                  ***  routine mpp_lnk_2d_icb  *** 
    … …  
    333398      !!                    nono   : number for local neighboring processors 
    334399      !!---------------------------------------------------------------------- 
    335       CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    336       REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    337       CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    338       REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    339       INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
    340       INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    341       ! 
    342       INTEGER  ::   jl   ! dummy loop indices 
    343       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    344       INTEGER  ::   ipreci, iprecj             !   -       - 
    345       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    346       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    347       !! 
    348       REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
    349       REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
    350       !!---------------------------------------------------------------------- 
    351  
    352       ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
    353       iprecj = nn_hls + kextj 
    354  
    355       IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
    356  
    357       ! 1. standard boundary treatment 
    358       ! ------------------------------ 
    359       ! Order matters Here !!!! 
    360       ! 
    361       !                                      ! East-West boundaries 
    362       !                                           !* Cyclic east-west 
    363       IF( l_Iperio ) THEN 
    364          pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
    365          pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
    366          ! 
    367       ELSE                                        !* closed 
    368          IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
    369                                       pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
    370       ENDIF 
    371       !                                      ! North-South boundaries 
    372       IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
    373          pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
    374          pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
    375       ELSE                                        !* closed 
    376          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
    377                                       pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
    378       ENDIF 
    379       ! 
    380  
    381       ! north fold treatment 
    382       ! ----------------------- 
    383       IF( npolj /= 0 ) THEN 
    384          ! 
    385          SELECT CASE ( jpni ) 
    386                    CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    387                    CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    388          END SELECT 
    389          ! 
    390       ENDIF 
    391  
    392       ! 2. East and west directions exchange 
    393       ! ------------------------------------ 
    394       ! we play with the neigbours AND the row number because of the periodicity 
    395       ! 
    396       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    397       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    398          iihom = jpi-nreci-kexti 
    399          DO jl = 1, ipreci 
    400             r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    401             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    402          END DO 
    403       END SELECT 
    404       ! 
    405       !                           ! Migrations 
    406       imigr = ipreci * ( jpj + 2*kextj ) 
    407       ! 
    408       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    409       ! 
    410       SELECT CASE ( nbondi ) 
    411       CASE ( -1 ) 
    412          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
    413          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    414          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    415       CASE ( 0 ) 
    416          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    417          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
    418          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    419          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    420          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    421          CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    422       CASE ( 1 ) 
    423          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    424          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    425          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    426       END SELECT 
    427       ! 
    428       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    429       ! 
    430       !                           ! Write Dirichlet lateral conditions 
    431       iihom = jpi - nn_hls 
    432       ! 
    433       SELECT CASE ( nbondi ) 
    434       CASE ( -1 ) 
    435          DO jl = 1, ipreci 
    436             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    437          END DO 
    438       CASE ( 0 ) 
    439          DO jl = 1, ipreci 
    440             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    441             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    442          END DO 
    443       CASE ( 1 ) 
    444          DO jl = 1, ipreci 
    445             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    446          END DO 
    447       END SELECT 
    448  
    449  
    450       ! 3. North and south directions 
    451       ! ----------------------------- 
    452       ! always closed : we play only with the neigbours 
    453       ! 
    454       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    455          ijhom = jpj-nrecj-kextj 
    456          DO jl = 1, iprecj 
    457             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    458             r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    459          END DO 
    460       ENDIF 
    461       ! 
    462       !                           ! Migrations 
    463       imigr = iprecj * ( jpi + 2*kexti ) 
    464       ! 
    465       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    466       ! 
    467       SELECT CASE ( nbondj ) 
    468       CASE ( -1 ) 
    469          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
    470          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    471          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    472       CASE ( 0 ) 
    473          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    474          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
    475          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    476          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    477          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    478          CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    479       CASE ( 1 ) 
    480          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    481          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    482          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    483       END SELECT 
    484       ! 
    485       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    486       ! 
    487       !                           ! Write Dirichlet lateral conditions 
    488       ijhom = jpj - nn_hls 
    489       ! 
    490       SELECT CASE ( nbondj ) 
    491       CASE ( -1 ) 
    492          DO jl = 1, iprecj 
    493             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    494          END DO 
    495       CASE ( 0 ) 
    496          DO jl = 1, iprecj 
    497             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    498             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    499          END DO 
    500       CASE ( 1 ) 
    501          DO jl = 1, iprecj 
    502             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    503          END DO 
    504       END SELECT 
    505       ! 
    506    END SUBROUTINE mpp_lnk_2d_icb 
    507     
     400 
     401#     define SINGLE_PRECISION 
     402#     define ROUTINE_LNK           mpp_lnk_2d_icb_sp 
     403#     include "mpp_lnk_icb_generic.h90" 
     404#     undef ROUTINE_LNK 
     405#     undef SINGLE_PRECISION 
     406#     define ROUTINE_LNK           mpp_lnk_2d_icb_dp 
     407#     include "mpp_lnk_icb_generic.h90" 
     408#     undef ROUTINE_LNK 
     409   
    508410END MODULE lbclnk 
    509411 

  • NEMO/trunk/src/OCE/LBC/lbcnfd.F90

    r11536 r13226  
    2626 
    2727   INTERFACE lbc_nfd 
    28       MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d 
    29       MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 
    30       MODULE PROCEDURE   lbc_nfd_2d_ext 
     28      MODULE PROCEDURE   lbc_nfd_2d_sp    , lbc_nfd_3d_sp    , lbc_nfd_4d_sp 
     29      MODULE PROCEDURE   lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp 
     30      MODULE PROCEDURE   lbc_nfd_2d_ext_sp 
     31      MODULE PROCEDURE   lbc_nfd_2d_dp    , lbc_nfd_3d_dp    , lbc_nfd_4d_dp 
     32      MODULE PROCEDURE   lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp 
     33      MODULE PROCEDURE   lbc_nfd_2d_ext_dp 
    3134   END INTERFACE 
    3235   ! 
    3336   INTERFACE lbc_nfd_nogather 
    3437!                        ! Currently only 4d array version is needed 
    35      MODULE PROCEDURE   lbc_nfd_nogather_2d    , lbc_nfd_nogather_3d 
    36      MODULE PROCEDURE   lbc_nfd_nogather_4d 
    37      MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 
     38     MODULE PROCEDURE   lbc_nfd_nogather_2d_sp    , lbc_nfd_nogather_3d_sp 
     39     MODULE PROCEDURE   lbc_nfd_nogather_4d_sp 
     40     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp 
     41     MODULE PROCEDURE   lbc_nfd_nogather_2d_dp    , lbc_nfd_nogather_3d_dp 
     42     MODULE PROCEDURE   lbc_nfd_nogather_4d_dp 
     43     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp 
    3844!     MODULE PROCEDURE   lbc_nfd_nogather_4d_ptr 
    3945   END INTERFACE 
    4046 
    41    TYPE, PUBLIC ::   PTR_2D   !: array of 2D pointers (also used in lib_mpp) 
    42       REAL(wp), DIMENSION (:,:)    , POINTER ::   pt2d 
    43    END TYPE PTR_2D 
    44    TYPE, PUBLIC ::   PTR_3D   !: array of 3D pointers (also used in lib_mpp) 
    45       REAL(wp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
    46    END TYPE PTR_3D 
    47    TYPE, PUBLIC ::   PTR_4D   !: array of 4D pointers (also used in lib_mpp) 
    48       REAL(wp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
    49    END TYPE PTR_4D 
     47   TYPE, PUBLIC ::   PTR_2D_dp   !: array of 2D pointers (also used in lib_mpp) 
     48      REAL(dp), DIMENSION (:,:)    , POINTER ::   pt2d 
     49   END TYPE PTR_2D_dp 
     50   TYPE, PUBLIC ::   PTR_3D_dp   !: array of 3D pointers (also used in lib_mpp) 
     51      REAL(dp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
     52   END TYPE PTR_3D_dp 
     53   TYPE, PUBLIC ::   PTR_4D_dp   !: array of 4D pointers (also used in lib_mpp) 
     54      REAL(dp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     55   END TYPE PTR_4D_dp 
     56 
     57   TYPE, PUBLIC ::   PTR_2D_sp   !: array of 2D pointers (also used in lib_mpp) 
     58      REAL(sp), DIMENSION (:,:)    , POINTER ::   pt2d 
     59   END TYPE PTR_2D_sp 
     60   TYPE, PUBLIC ::   PTR_3D_sp   !: array of 3D pointers (also used in lib_mpp) 
     61      REAL(sp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
     62   END TYPE PTR_3D_sp 
     63   TYPE, PUBLIC ::   PTR_4D_sp   !: array of 4D pointers (also used in lib_mpp) 
     64      REAL(sp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     65   END TYPE PTR_4D_sp 
     66 
    5067 
    5168   PUBLIC   lbc_nfd            ! north fold conditions 
    … …  
    7592   !!---------------------------------------------------------------------- 
    7693   ! 
    77    !                       !==  2D array and array of 2D pointer  ==! 
    78    ! 
    79 #  define DIM_2d 
    80 #     define ROUTINE_NFD           lbc_nfd_2d 
    81 #     include "lbc_nfd_generic.h90" 
    82 #     undef ROUTINE_NFD 
    83 #     define MULTI 
    84 #     define ROUTINE_NFD           lbc_nfd_2d_ptr 
     94   !                       !==  SINGLE PRECISION VERSIONS 
     95   ! 
     96   ! 
     97   !                       !==  2D array and array of 2D pointer  ==! 
     98   ! 
     99#  define SINGLE_PRECISION 
     100#  define DIM_2d 
     101#     define ROUTINE_NFD           lbc_nfd_2d_sp 
     102#     include "lbc_nfd_generic.h90" 
     103#     undef ROUTINE_NFD 
     104#     define MULTI 
     105#     define ROUTINE_NFD           lbc_nfd_2d_ptr_sp 
    85106#     include "lbc_nfd_generic.h90" 
    86107#     undef ROUTINE_NFD 
    … …  
    91112   ! 
    92113#  define DIM_2d 
    93 #     define ROUTINE_NFD           lbc_nfd_2d_ext 
     114#     define ROUTINE_NFD           lbc_nfd_2d_ext_sp 
    94115#     include "lbc_nfd_ext_generic.h90" 
    95116#     undef ROUTINE_NFD 
    … …  
    99120   ! 
    100121#  define DIM_3d 
    101 #     define ROUTINE_NFD           lbc_nfd_3d 
    102 #     include "lbc_nfd_generic.h90" 
    103 #     undef ROUTINE_NFD 
    104 #     define MULTI 
    105 #     define ROUTINE_NFD           lbc_nfd_3d_ptr 
    106 #     include "lbc_nfd_generic.h90" 
    107 #     undef ROUTINE_NFD 
    108 #     undef MULTI 
    109 #  undef DIM_3d 
    110    ! 
    111    !                       !==  4D array and array of 4D pointer  ==! 
    112    ! 
    113 #  define DIM_4d 
    114 #     define ROUTINE_NFD           lbc_nfd_4d 
    115 #     include "lbc_nfd_generic.h90" 
    116 #     undef ROUTINE_NFD 
    117 #     define MULTI 
    118 #     define ROUTINE_NFD           lbc_nfd_4d_ptr 
     122#     define ROUTINE_NFD           lbc_nfd_3d_sp 
     123#     include "lbc_nfd_generic.h90" 
     124#     undef ROUTINE_NFD 
     125#     define MULTI 
     126#     define ROUTINE_NFD           lbc_nfd_3d_ptr_sp 
     127#     include "lbc_nfd_generic.h90" 
     128#     undef ROUTINE_NFD 
     129#     undef MULTI 
     130#  undef DIM_3d 
     131   ! 
     132   !                       !==  4D array and array of 4D pointer  ==! 
     133   ! 
     134#  define DIM_4d 
     135#     define ROUTINE_NFD           lbc_nfd_4d_sp 
     136#     include "lbc_nfd_generic.h90" 
     137#     undef ROUTINE_NFD 
     138#     define MULTI 
     139#     define ROUTINE_NFD           lbc_nfd_4d_ptr_sp 
    119140#     include "lbc_nfd_generic.h90" 
    120141#     undef ROUTINE_NFD 
    … …  
    127148   ! 
    128149#  define DIM_2d 
    129 #     define ROUTINE_NFD           lbc_nfd_nogather_2d 
    130 #     include "lbc_nfd_nogather_generic.h90" 
    131 #     undef ROUTINE_NFD 
    132 #     define MULTI 
    133 #     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr 
    134 #     include "lbc_nfd_nogather_generic.h90" 
    135 #     undef ROUTINE_NFD 
    136 #     undef MULTI 
    137 #  undef DIM_2d 
    138    ! 
    139    !                       !==  3D array and array of 3D pointer  ==! 
    140    ! 
    141 #  define DIM_3d 
    142 #     define ROUTINE_NFD           lbc_nfd_nogather_3d 
    143 #     include "lbc_nfd_nogather_generic.h90" 
    144 #     undef ROUTINE_NFD 
    145 #     define MULTI 
    146 #     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr 
    147 #     include "lbc_nfd_nogather_generic.h90" 
    148 #     undef ROUTINE_NFD 
    149 #     undef MULTI 
    150 #  undef DIM_3d 
    151    ! 
    152    !                       !==  4D array and array of 4D pointer  ==! 
    153    ! 
    154 #  define DIM_4d 
    155 #     define ROUTINE_NFD           lbc_nfd_nogather_4d 
     150#     define ROUTINE_NFD           lbc_nfd_nogather_2d_sp 
     151#     include "lbc_nfd_nogather_generic.h90" 
     152#     undef ROUTINE_NFD 
     153#     define MULTI 
     154#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr_sp 
     155#     include "lbc_nfd_nogather_generic.h90" 
     156#     undef ROUTINE_NFD 
     157#     undef MULTI 
     158#  undef DIM_2d 
     159   ! 
     160   !                       !==  3D array and array of 3D pointer  ==! 
     161   ! 
     162#  define DIM_3d 
     163#     define ROUTINE_NFD           lbc_nfd_nogather_3d_sp 
     164#     include "lbc_nfd_nogather_generic.h90" 
     165#     undef ROUTINE_NFD 
     166#     define MULTI 
     167#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr_sp 
     168#     include "lbc_nfd_nogather_generic.h90" 
     169#     undef ROUTINE_NFD 
     170#     undef MULTI 
     171#  undef DIM_3d 
     172   ! 
     173   !                       !==  4D array and array of 4D pointer  ==! 
     174   ! 
     175#  define DIM_4d 
     176#     define ROUTINE_NFD           lbc_nfd_nogather_4d_sp 
    156177#     include "lbc_nfd_nogather_generic.h90" 
    157178#     undef ROUTINE_NFD 
    … …  
    162183!#     undef MULTI 
    163184#  undef DIM_4d 
    164  
    165    !!---------------------------------------------------------------------- 
     185#  undef SINGLE_PRECISION 
     186 
     187   !!---------------------------------------------------------------------- 
     188   ! 
     189   !                       !==  DOUBLE PRECISION VERSIONS 
     190   ! 
     191   ! 
     192   !                       !==  2D array and array of 2D pointer  ==! 
     193   ! 
     194#  define DIM_2d 
     195#     define ROUTINE_NFD           lbc_nfd_2d_dp 
     196#     include "lbc_nfd_generic.h90" 
     197#     undef ROUTINE_NFD 
     198#     define MULTI 
     199#     define ROUTINE_NFD           lbc_nfd_2d_ptr_dp 
     200#     include "lbc_nfd_generic.h90" 
     201#     undef ROUTINE_NFD 
     202#     undef MULTI 
     203#  undef DIM_2d 
     204   ! 
     205   !                       !==  2D array with extra haloes  ==! 
     206   ! 
     207#  define DIM_2d 
     208#     define ROUTINE_NFD           lbc_nfd_2d_ext_dp 
     209#     include "lbc_nfd_ext_generic.h90" 
     210#     undef ROUTINE_NFD 
     211#  undef DIM_2d 
     212   ! 
     213   !                       !==  3D array and array of 3D pointer  ==! 
     214   ! 
     215#  define DIM_3d 
     216#     define ROUTINE_NFD           lbc_nfd_3d_dp 
     217#     include "lbc_nfd_generic.h90" 
     218#     undef ROUTINE_NFD 
     219#     define MULTI 
     220#     define ROUTINE_NFD           lbc_nfd_3d_ptr_dp 
     221#     include "lbc_nfd_generic.h90" 
     222#     undef ROUTINE_NFD 
     223#     undef MULTI 
     224#  undef DIM_3d 
     225   ! 
     226   !                       !==  4D array and array of 4D pointer  ==! 
     227   ! 
     228#  define DIM_4d 
     229#     define ROUTINE_NFD           lbc_nfd_4d_dp 
     230#     include "lbc_nfd_generic.h90" 
     231#     undef ROUTINE_NFD 
     232#     define MULTI 
     233#     define ROUTINE_NFD           lbc_nfd_4d_ptr_dp 
     234#     include "lbc_nfd_generic.h90" 
     235#     undef ROUTINE_NFD 
     236#     undef MULTI 
     237#  undef DIM_4d 
     238   ! 
     239   !  lbc_nfd_nogather routines 
     240   ! 
     241   !                       !==  2D array and array of 2D pointer  ==! 
     242   ! 
     243#  define DIM_2d 
     244#     define ROUTINE_NFD           lbc_nfd_nogather_2d_dp 
     245#     include "lbc_nfd_nogather_generic.h90" 
     246#     undef ROUTINE_NFD 
     247#     define MULTI 
     248#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr_dp 
     249#     include "lbc_nfd_nogather_generic.h90" 
     250#     undef ROUTINE_NFD 
     251#     undef MULTI 
     252#  undef DIM_2d 
     253   ! 
     254   !                       !==  3D array and array of 3D pointer  ==! 
     255   ! 
     256#  define DIM_3d 
     257#     define ROUTINE_NFD           lbc_nfd_nogather_3d_dp 
     258#     include "lbc_nfd_nogather_generic.h90" 
     259#     undef ROUTINE_NFD 
     260#     define MULTI 
     261#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr_dp 
     262#     include "lbc_nfd_nogather_generic.h90" 
     263#     undef ROUTINE_NFD 
     264#     undef MULTI 
     265#  undef DIM_3d 
     266   ! 
     267   !                       !==  4D array and array of 4D pointer  ==! 
     268   ! 
     269#  define DIM_4d 
     270#     define ROUTINE_NFD           lbc_nfd_nogather_4d_dp 
     271#     include "lbc_nfd_nogather_generic.h90" 
     272#     undef ROUTINE_NFD 
     273!#     define MULTI 
     274!#     define ROUTINE_NFD           lbc_nfd_nogather_4d_ptr 
     275!#     include "lbc_nfd_nogather_generic.h90" 
     276!#     undef ROUTINE_NFD 
     277!#     undef MULTI 
     278#  undef DIM_4d 
     279 
     280   !!---------------------------------------------------------------------- 
     281 
    166282 
    167283 

  • NEMO/trunk/src/OCE/LBC/lib_mpp.F90

    r13216 r13226  
    6767   PUBLIC   mpp_ini_znl 
    6868   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
     69   PUBLIC   mppsend_sp, mpprecv_sp                          ! needed by TAM and ICB routines 
     70   PUBLIC   mppsend_dp, mpprecv_dp                          ! needed by TAM and ICB routines 
    6971   PUBLIC   mpp_report 
    7072   PUBLIC   mpp_bcast_nml 
    … …  
    7981   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ 
    8082   INTERFACE mpp_min 
    81       MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
     83      MODULE PROCEDURE mppmin_a_int, mppmin_int 
     84      MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp 
     85      MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp 
    8286   END INTERFACE 
    8387   INTERFACE mpp_max 
    84       MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
     88      MODULE PROCEDURE mppmax_a_int, mppmax_int 
     89      MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp 
     90      MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp 
    8591   END INTERFACE 
    8692   INTERFACE mpp_sum 
    87       MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   & 
    88          &             mppsum_realdd, mppsum_a_realdd 
     93      MODULE PROCEDURE mppsum_a_int, mppsum_int 
     94      MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd 
     95      MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp 
     96      MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp 
    8997   END INTERFACE 
    9098   INTERFACE mpp_minloc 
    91       MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
     99      MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp 
     100      MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp 
    92101   END INTERFACE 
    93102   INTERFACE mpp_maxloc 
    94       MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     103      MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp 
     104      MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp 
    95105   END INTERFACE 
    96106 
    … …  
    158168   TYPE, PUBLIC ::   DELAYARR 
    159169      REAL(   wp), POINTER, DIMENSION(:) ::  z1d => NULL() 
    160       COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
     170      COMPLEX(dp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    161171   END TYPE DELAYARR 
    162172   TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE  ::   todelay         !: must have SAVE for default initialization of DELAYARR 
    … …  
    164174 
    165175   ! timing summary report 
    166    REAL(wp), DIMENSION(2), PUBLIC ::  waiting_time = 0._wp 
    167    REAL(wp)              , PUBLIC ::  compute_time = 0._wp, elapsed_time = 0._wp 
     176   REAL(dp), DIMENSION(2), PUBLIC ::  waiting_time = 0._dp 
     177   REAL(dp)              , PUBLIC ::  compute_time = 0._dp, elapsed_time = 0._dp 
    168178    
    169179   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend 
    … …  
    251261      !! 
    252262      INTEGER ::   iflag 
     263      INTEGER :: mpi_working_type 
     264      !!---------------------------------------------------------------------- 
     265      ! 
     266#if defined key_mpp_mpi 
     267      IF (wp == dp) THEN 
     268         mpi_working_type = mpi_double_precision 
     269      ELSE 
     270         mpi_working_type = mpi_real 
     271      END IF 
     272      CALL mpi_isend( pmess, kbytes, mpi_working_type, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     273#endif 
     274      ! 
     275   END SUBROUTINE mppsend 
     276 
     277 
     278   SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) 
     279      !!---------------------------------------------------------------------- 
     280      !!                  ***  routine mppsend  *** 
     281      !! 
     282      !! ** Purpose :   Send messag passing array 
     283      !! 
     284      !!---------------------------------------------------------------------- 
     285      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     286      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     287      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     288      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     289      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     290      !! 
     291      INTEGER ::   iflag 
    253292      !!---------------------------------------------------------------------- 
    254293      ! 
    … …  
    257296#endif 
    258297      ! 
    259    END SUBROUTINE mppsend 
     298   END SUBROUTINE mppsend_dp 
     299 
     300 
     301   SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) 
     302      !!---------------------------------------------------------------------- 
     303      !!                  ***  routine mppsend  *** 
     304      !! 
     305      !! ** Purpose :   Send messag passing array 
     306      !! 
     307      !!---------------------------------------------------------------------- 
     308      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     309      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     310      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     311      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     312      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     313      !! 
     314      INTEGER ::   iflag 
     315      !!---------------------------------------------------------------------- 
     316      ! 
     317#if defined key_mpp_mpi 
     318      CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     319#endif 
     320      ! 
     321   END SUBROUTINE mppsend_sp 
    260322 
    261323 
    … …  
    275337      INTEGER :: iflag 
    276338      INTEGER :: use_source 
     339      INTEGER :: mpi_working_type 
    277340      !!---------------------------------------------------------------------- 
    278341      ! 
    … …  
    283346      IF( PRESENT(ksource) )   use_source = ksource 
    284347      ! 
     348      IF (wp == dp) THEN 
     349         mpi_working_type = mpi_double_precision 
     350      ELSE 
     351         mpi_working_type = mpi_real 
     352      END IF 
     353      CALL mpi_recv( pmess, kbytes, mpi_working_type, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     354#endif 
     355      ! 
     356   END SUBROUTINE mpprecv 
     357 
     358   SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) 
     359      !!---------------------------------------------------------------------- 
     360      !!                  ***  routine mpprecv  *** 
     361      !! 
     362      !! ** Purpose :   Receive messag passing array 
     363      !! 
     364      !!---------------------------------------------------------------------- 
     365      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     366      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     367      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     368      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     369      !! 
     370      INTEGER :: istatus(mpi_status_size) 
     371      INTEGER :: iflag 
     372      INTEGER :: use_source 
     373      !!---------------------------------------------------------------------- 
     374      ! 
     375#if defined key_mpp_mpi 
     376      ! If a specific process number has been passed to the receive call, 
     377      ! use that one. Default is to use mpi_any_source 
     378      use_source = mpi_any_source 
     379      IF( PRESENT(ksource) )   use_source = ksource 
     380      ! 
    285381      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
    286382#endif 
    287383      ! 
    288    END SUBROUTINE mpprecv 
     384   END SUBROUTINE mpprecv_dp 
     385 
     386 
     387   SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) 
     388      !!---------------------------------------------------------------------- 
     389      !!                  ***  routine mpprecv  *** 
     390      !! 
     391      !! ** Purpose :   Receive messag passing array 
     392      !! 
     393      !!---------------------------------------------------------------------- 
     394      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     395      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     396      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     397      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     398      !! 
     399      INTEGER :: istatus(mpi_status_size) 
     400      INTEGER :: iflag 
     401      INTEGER :: use_source 
     402      !!---------------------------------------------------------------------- 
     403      ! 
     404#if defined key_mpp_mpi 
     405      ! If a specific process number has been passed to the receive call, 
     406      ! use that one. Default is to use mpi_any_source 
     407      use_source = mpi_any_source 
     408      IF( PRESENT(ksource) )   use_source = ksource 
     409      ! 
     410      CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     411#endif 
     412      ! 
     413   END SUBROUTINE mpprecv_sp 
    289414 
    290415 
    … …  
    351476      CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    352477      CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    353       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_in 
     478      COMPLEX(dp),      INTENT(in   ), DIMENSION(:) ::   y_in 
    354479      REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    355480      LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    … …  
    359484      INTEGER ::   idvar 
    360485      INTEGER ::   ierr, ilocalcomm 
    361       COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
     486      COMPLEX(dp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    362487      !!---------------------------------------------------------------------- 
    363488#if defined key_mpp_mpi 
    … …  
    432557      INTEGER ::   idvar 
    433558      INTEGER ::   ierr, ilocalcomm 
    434       !!---------------------------------------------------------------------- 
    435 #if defined key_mpp_mpi 
     559      INTEGER ::   MPI_TYPE 
     560      !!---------------------------------------------------------------------- 
     561       
     562#if defined key_mpp_mpi 
     563      if( wp == dp ) then 
     564         MPI_TYPE = MPI_DOUBLE_PRECISION 
     565      else if ( wp == sp ) then 
     566         MPI_TYPE = MPI_REAL 
     567      else 
     568        CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) 
     569    
     570      end if 
     571 
    436572      ilocalcomm = mpi_comm_oce 
    437573      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    470606# if defined key_mpi2 
    471607      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    472       CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) 
    473       ndelayid(idvar) = 1 
     608      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    474609      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    475610# else 
    476       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     611      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    477612# endif 
    478613#else 
    … …  
    551686#  undef INTEGER_TYPE 
    552687! 
     688   !! 
     689   !!   ----   SINGLE PRECISION VERSIONS 
     690   !! 
     691#  define SINGLE_PRECISION 
    553692#  define REAL_TYPE 
    554693#  define DIM_0d 
    555 #     define ROUTINE_ALLREDUCE           mppmax_real 
     694#     define ROUTINE_ALLREDUCE           mppmax_real_sp 
    556695#     include "mpp_allreduce_generic.h90" 
    557696#     undef ROUTINE_ALLREDUCE 
    558697#  undef DIM_0d 
    559698#  define DIM_1d 
    560 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
     699#     define ROUTINE_ALLREDUCE           mppmax_a_real_sp 
     700#     include "mpp_allreduce_generic.h90" 
     701#     undef ROUTINE_ALLREDUCE 
     702#  undef DIM_1d 
     703#  undef SINGLE_PRECISION 
     704   !! 
     705   !! 
     706   !!   ----   DOUBLE PRECISION VERSIONS 
     707   !! 
     708! 
     709#  define DIM_0d 
     710#     define ROUTINE_ALLREDUCE           mppmax_real_dp 
     711#     include "mpp_allreduce_generic.h90" 
     712#     undef ROUTINE_ALLREDUCE 
     713#  undef DIM_0d 
     714#  define DIM_1d 
     715#     define ROUTINE_ALLREDUCE           mppmax_a_real_dp 
    561716#     include "mpp_allreduce_generic.h90" 
    562717#     undef ROUTINE_ALLREDUCE 
    … …  
    583738#  undef INTEGER_TYPE 
    584739! 
     740   !! 
     741   !!   ----   SINGLE PRECISION VERSIONS 
     742   !! 
     743#  define SINGLE_PRECISION 
    585744#  define REAL_TYPE 
    586745#  define DIM_0d 
    587 #     define ROUTINE_ALLREDUCE           mppmin_real 
     746#     define ROUTINE_ALLREDUCE           mppmin_real_sp 
    588747#     include "mpp_allreduce_generic.h90" 
    589748#     undef ROUTINE_ALLREDUCE 
    590749#  undef DIM_0d 
    591750#  define DIM_1d 
    592 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
     751#     define ROUTINE_ALLREDUCE           mppmin_a_real_sp 
     752#     include "mpp_allreduce_generic.h90" 
     753#     undef ROUTINE_ALLREDUCE 
     754#  undef DIM_1d 
     755#  undef SINGLE_PRECISION 
     756   !! 
     757   !!   ----   DOUBLE PRECISION VERSIONS 
     758   !! 
     759 
     760#  define DIM_0d 
     761#     define ROUTINE_ALLREDUCE           mppmin_real_dp 
     762#     include "mpp_allreduce_generic.h90" 
     763#     undef ROUTINE_ALLREDUCE 
     764#  undef DIM_0d 
     765#  define DIM_1d 
     766#     define ROUTINE_ALLREDUCE           mppmin_a_real_dp 
    593767#     include "mpp_allreduce_generic.h90" 
    594768#     undef ROUTINE_ALLREDUCE 
    … …  
    616790#  undef DIM_1d 
    617791#  undef INTEGER_TYPE 
    618 ! 
     792 
     793   !! 
     794   !!   ----   SINGLE PRECISION VERSIONS 
     795   !! 
     796#  define OPERATION_SUM 
     797#  define SINGLE_PRECISION 
    619798#  define REAL_TYPE 
    620799#  define DIM_0d 
    621 #     define ROUTINE_ALLREDUCE           mppsum_real 
     800#     define ROUTINE_ALLREDUCE           mppsum_real_sp 
    622801#     include "mpp_allreduce_generic.h90" 
    623802#     undef ROUTINE_ALLREDUCE 
    624803#  undef DIM_0d 
    625804#  define DIM_1d 
    626 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
     805#     define ROUTINE_ALLREDUCE           mppsum_a_real_sp 
     806#     include "mpp_allreduce_generic.h90" 
     807#     undef ROUTINE_ALLREDUCE 
     808#  undef DIM_1d 
     809#  undef REAL_TYPE 
     810#  undef OPERATION_SUM 
     811 
     812#  undef SINGLE_PRECISION 
     813 
     814   !! 
     815   !!   ----   DOUBLE PRECISION VERSIONS 
     816   !! 
     817#  define OPERATION_SUM 
     818#  define REAL_TYPE 
     819#  define DIM_0d 
     820#     define ROUTINE_ALLREDUCE           mppsum_real_dp 
     821#     include "mpp_allreduce_generic.h90" 
     822#     undef ROUTINE_ALLREDUCE 
     823#  undef DIM_0d 
     824#  define DIM_1d 
     825#     define ROUTINE_ALLREDUCE           mppsum_a_real_dp 
    627826#     include "mpp_allreduce_generic.h90" 
    628827#     undef ROUTINE_ALLREDUCE 
    … …  
    651850   !!---------------------------------------------------------------------- 
    652851   !! 
     852   !! 
     853   !!   ----   SINGLE PRECISION VERSIONS 
     854   !! 
     855#  define SINGLE_PRECISION 
    653856#  define OPERATION_MINLOC 
    654857#  define DIM_2d 
    655 #     define ROUTINE_LOC           mpp_minloc2d 
     858#     define ROUTINE_LOC           mpp_minloc2d_sp 
    656859#     include "mpp_loc_generic.h90" 
    657860#     undef ROUTINE_LOC 
    658861#  undef DIM_2d 
    659862#  define DIM_3d 
    660 #     define ROUTINE_LOC           mpp_minloc3d 
     863#     define ROUTINE_LOC           mpp_minloc3d_sp 
    661864#     include "mpp_loc_generic.h90" 
    662865#     undef ROUTINE_LOC 
    … …  
    666869#  define OPERATION_MAXLOC 
    667870#  define DIM_2d 
    668 #     define ROUTINE_LOC           mpp_maxloc2d 
     871#     define ROUTINE_LOC           mpp_maxloc2d_sp 
    669872#     include "mpp_loc_generic.h90" 
    670873#     undef ROUTINE_LOC 
    671874#  undef DIM_2d 
    672875#  define DIM_3d 
    673 #     define ROUTINE_LOC           mpp_maxloc3d 
     876#     define ROUTINE_LOC           mpp_maxloc3d_sp 
    674877#     include "mpp_loc_generic.h90" 
    675878#     undef ROUTINE_LOC 
    676879#  undef DIM_3d 
    677880#  undef OPERATION_MAXLOC 
     881#  undef SINGLE_PRECISION 
     882   !! 
     883   !!   ----   DOUBLE PRECISION VERSIONS 
     884   !! 
     885#  define OPERATION_MINLOC 
     886#  define DIM_2d 
     887#     define ROUTINE_LOC           mpp_minloc2d_dp 
     888#     include "mpp_loc_generic.h90" 
     889#     undef ROUTINE_LOC 
     890#  undef DIM_2d 
     891#  define DIM_3d 
     892#     define ROUTINE_LOC           mpp_minloc3d_dp 
     893#     include "mpp_loc_generic.h90" 
     894#     undef ROUTINE_LOC 
     895#  undef DIM_3d 
     896#  undef OPERATION_MINLOC 
     897 
     898#  define OPERATION_MAXLOC 
     899#  define DIM_2d 
     900#     define ROUTINE_LOC           mpp_maxloc2d_dp 
     901#     include "mpp_loc_generic.h90" 
     902#     undef ROUTINE_LOC 
     903#  undef DIM_2d 
     904#  define DIM_3d 
     905#     define ROUTINE_LOC           mpp_maxloc3d_dp 
     906#     include "mpp_loc_generic.h90" 
     907#     undef ROUTINE_LOC 
     908#  undef DIM_3d 
     909#  undef OPERATION_MAXLOC 
     910 
    678911 
    679912   SUBROUTINE mppsync() 
    … …  
    9041137      !!--------------------------------------------------------------------- 
    9051138      INTEGER                     , INTENT(in)    ::   ilen, itype 
    906       COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::   ydda 
    907       COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::   yddb 
    908       ! 
    909       REAL(wp) :: zerr, zt1, zt2    ! local work variables 
     1139      COMPLEX(dp), DIMENSION(ilen), INTENT(in)    ::   ydda 
     1140      COMPLEX(dp), DIMENSION(ilen), INTENT(inout) ::   yddb 
     1141      ! 
     1142      REAL(dp) :: zerr, zt1, zt2    ! local work variables 
    9101143      INTEGER  :: ji, ztmp           ! local scalar 
    9111144      !!--------------------------------------------------------------------- 
    … …  
    10601293    LOGICAL,           INTENT(IN) :: ld_tic 
    10611294    LOGICAL, OPTIONAL, INTENT(IN) :: ld_global 
    1062     REAL(wp), DIMENSION(2), SAVE :: tic_wt 
    1063     REAL(wp),               SAVE :: tic_ct = 0._wp 
     1295    REAL(dp), DIMENSION(2), SAVE :: tic_wt 
     1296    REAL(dp),               SAVE :: tic_ct = 0._dp 
    10641297    INTEGER :: ii 
    10651298#if defined key_mpp_mpi 
    … …  
    10741307    IF ( ld_tic ) THEN 
    10751308       tic_wt(ii) = MPI_Wtime()                                                    ! start count tic->tac (waiting time) 
    1076        IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic 
     1309       IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic 
    10771310    ELSE 
    10781311       waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii)              ! cumulate count tic->tac 

  • NEMO/trunk/src/OCE/LBC/mpp_allreduce_generic.h90

    r10425 r13226  
    11!                          !==  IN: ptab is an array  ==! 
    22#   if defined REAL_TYPE 
    3 #      define ARRAY_TYPE(i)    REAL(wp)         , INTENT(inout) ::   ARRAY_IN(i) 
    4 #      define TMP_TYPE(i)      REAL(wp)         , ALLOCATABLE   ::   work(i) 
    5 #      define MPI_TYPE mpi_double_precision 
     3#      if defined SINGLE_PRECISION 
     4#         define ARRAY_TYPE(i)    REAL(sp)         , INTENT(inout) ::   ARRAY_IN(i) 
     5#         define TMP_TYPE(i)      REAL(sp)         , ALLOCATABLE   ::   work(i) 
     6#         define MPI_TYPE mpi_real 
     7#      else 
     8#         define ARRAY_TYPE(i)    REAL(dp)         , INTENT(inout) ::   ARRAY_IN(i) 
     9#         define TMP_TYPE(i)      REAL(dp)         , ALLOCATABLE   ::   work(i) 
     10#         define MPI_TYPE mpi_double_precision 
     11#      endif  
    612#   endif 
    713#   if defined INTEGER_TYPE 
    … …  
    1117#   endif 
    1218#   if defined COMPLEX_TYPE 
    13 #      define ARRAY_TYPE(i)    COMPLEX          , INTENT(inout) ::   ARRAY_IN(i) 
    14 #      define TMP_TYPE(i)      COMPLEX          , ALLOCATABLE   ::   work(i) 
     19#      define ARRAY_TYPE(i)    COMPLEX(dp)       , INTENT(inout) ::   ARRAY_IN(i) 
     20#      define TMP_TYPE(i)      COMPLEX(dp)       , ALLOCATABLE   ::   work(i) 
    1521#      define MPI_TYPE mpi_double_complex 
    1622#   endif 
    … …  
    7581   END SUBROUTINE ROUTINE_ALLREDUCE 
    7682 
     83#undef PRECISION 
    7784#undef ARRAY_TYPE 
    7885#undef ARRAY_IN 

  • NEMO/trunk/src/OCE/LBC/mpp_lnk_generic.h90

    r11536 r13226  
    55#   define OPT_K(k)                 ,ipf 
    66#   if defined DIM_2d 
    7 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)                , INTENT(inout) ::   ptab(f) 
     7#      if defined SINGLE_PRECISION 
     8#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp)                , INTENT(inout) ::   ptab(f) 
     9#      else 
     10#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp)                , INTENT(inout) ::   ptab(f) 
     11#      endif 
    812#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    913#      define K_SIZE(ptab)             1 
    … …  
    1115#   endif 
    1216#   if defined DIM_3d 
    13 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)                , INTENT(inout) ::   ptab(f) 
     17#      if defined SINGLE_PRECISION 
     18#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp)                , INTENT(inout) ::   ptab(f) 
     19#      else 
     20#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp)                , INTENT(inout) ::   ptab(f) 
     21#      endif 
    1422#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    1523#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    … …  
    1725#   endif 
    1826#   if defined DIM_4d 
    19 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)                , INTENT(inout) ::   ptab(f) 
     27#      if defined SINGLE_PRECISION 
     28#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp)                , INTENT(inout) ::   ptab(f) 
     29#      else 
     30#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp)                , INTENT(inout) ::   ptab(f) 
     31#      endif 
    2032#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    2133#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    … …  
    2335#   endif 
    2436#else 
    25 #   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     37#   if defined SINGLE_PRECISION 
     38#      define ARRAY_TYPE(i,j,k,l,f)    REAL(sp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     39#   else 
     40#      define ARRAY_TYPE(i,j,k,l,f)    REAL(dp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     41#   endif 
    2642#   define NAT_IN(k)                cd_nat 
    2743#   define SGN_IN(k)                psgn 
    … …  
    4460#   endif 
    4561#endif 
     62 
     63# if defined SINGLE_PRECISION 
     64#    define PRECISION sp 
     65#    define SENDROUTINE mppsend_sp 
     66#    define RECVROUTINE mpprecv_sp 
     67# else 
     68#    define PRECISION dp 
     69#    define SENDROUTINE mppsend_dp 
     70#    define RECVROUTINE mpprecv_dp 
     71# endif 
    4672 
    4773#if defined MULTI 
    … …  
    6793      INTEGER  ::   ifill_we, ifill_ea, ifill_so, ifill_no 
    6894      INTEGER  ::   ihl                          ! number of ranks and rows to be communicated  
    69       REAL(wp) ::   zland 
     95      REAL(PRECISION) ::   zland 
    7096      INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   istat          ! for mpi_isend 
    71       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_we, zrcv_we, zsnd_ea, zrcv_ea   ! east -west  & west - east  halos 
    72       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_so, zrcv_so, zsnd_no, zrcv_no   ! north-south & south-north  halos 
     97      REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_we, zrcv_we, zsnd_ea, zrcv_ea   ! east -west  & west - east  halos 
     98      REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_so, zrcv_so, zsnd_no, zrcv_no   ! north-south & south-north  halos 
    7399      LOGICAL  ::   llsend_we, llsend_ea, llsend_no, llsend_so       ! communication send 
    74100      LOGICAL  ::   llrecv_we, llrecv_ea, llrecv_no, llrecv_so       ! communication receive  
    … …  
    174200      ! 
    175201      ! non-blocking send of the western/eastern side using local temporary arrays 
    176       IF( llsend_we )   CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 
    177       IF( llsend_ea )   CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 
     202      IF( llsend_we )   CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 
     203      IF( llsend_ea )   CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 
    178204      ! blocking receive of the western/eastern halo in local temporary arrays 
    179       IF( llrecv_we )   CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 
    180       IF( llrecv_ea )   CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 
     205      IF( llrecv_we )   CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 
     206      IF( llrecv_ea )   CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 
    181207      ! 
    182208      IF( ln_timing ) CALL tic_tac(.FALSE.) 
    … …  
    289315      ! 
    290316      ! non-blocking send of the southern/northern side 
    291       IF( llsend_so )   CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 
    292       IF( llsend_no )   CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 
     317      IF( llsend_so )   CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 
     318      IF( llsend_no )   CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 
    293319      ! blocking receive of the southern/northern halo 
    294       IF( llrecv_so )   CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) 
    295       IF( llrecv_no )   CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) 
     320      IF( llrecv_so )   CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso ) 
     321      IF( llrecv_no )   CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono ) 
    296322      ! 
    297323      IF( ln_timing ) CALL tic_tac(.FALSE.) 

  • NEMO/trunk/src/OCE/LBC/mpp_loc_generic.h90

    r12933 r13226  
    11                          !==  IN: ptab is an array  ==! 
    2 #      define ARRAY_TYPE(i,j,k)    REAL(wp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k) 
    3 #      define MASK_TYPE(i,j,k)     REAL(wp)        , INTENT(in   ) ::   MASK_IN(i,j,k) 
     2#   if defined SINGLE_PRECISION 
     3#      define ARRAY_TYPE(i,j,k)    REAL(sp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k) 
     4#      define MASK_TYPE(i,j,k)     REAL(sp)        , INTENT(in   ) ::   MASK_IN(i,j,k) 
     5#      define PRECISION sp 
     6#   else 
     7#      define ARRAY_TYPE(i,j,k)    REAL(dp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k) 
     8#      define MASK_TYPE(i,j,k)     REAL(dp)        , INTENT(in   ) ::   MASK_IN(i,j,k) 
     9#      define PRECISION dp 
     10#   endif 
     11 
    412#   if defined DIM_2d 
    513#      define ARRAY_IN(i,j,k)   ptab(i,j) 
    … …  
    3038      ARRAY_TYPE(:,:,:)                            ! array on which loctrans operation is applied 
    3139      MASK_TYPE(:,:,:)                             ! local mask 
    32       REAL(wp)        , INTENT(  out) ::   pmin    ! Global minimum of ptab 
     40      REAL(PRECISION)        , INTENT(  out) ::   pmin    ! Global minimum of ptab 
    3341      INDEX_TYPE(:)                                ! index of minimum in global frame 
    3442      ! 
    3543      INTEGER  ::   ierror, ii, idim 
    3644      INTEGER  ::   index0 
    37       REAL(wp) ::   zmin     ! local minimum 
     45      REAL(PRECISION) ::   zmin     ! local minimum 
    3846      INTEGER , DIMENSION(:), ALLOCATABLE  ::   ilocs 
    39       REAL(wp), DIMENSION(2,1) ::   zain, zaout 
     47      REAL(dp), DIMENSION(2,1) ::   zain, zaout 
    4048      !!----------------------------------------------------------------------- 
    4149      ! 
    … …  
    98106   END SUBROUTINE ROUTINE_LOC 
    99107 
     108 
     109#undef PRECISION 
    100110#undef ARRAY_TYPE 
    101111#undef MAX_TYPE 

  • NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90

    r11536 r13226  
    55#   define LBC_ARG                  (jf) 
    66#   if defined DIM_2d 
    7 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)     , INTENT(inout) ::   ptab(f) 
     7#      if defined SINGLE_PRECISION 
     8#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp)     , INTENT(inout) ::   ptab(f) 
     9#      else 
     10#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp)     , INTENT(inout) ::   ptab(f) 
     11#      endif 
    812#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    913#      define K_SIZE(ptab)             1 
    … …  
    1115#   endif 
    1216#   if defined DIM_3d 
    13 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)     , INTENT(inout) ::   ptab(f) 
     17#      if defined SINGLE_PRECISION 
     18#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp)     , INTENT(inout) ::   ptab(f) 
     19#      else 
     20#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp)     , INTENT(inout) ::   ptab(f) 
     21#      endif 
    1422#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    1523#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    … …  
    1725#   endif 
    1826#   if defined DIM_4d 
    19 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)     , INTENT(inout) ::   ptab(f) 
     27#      if defined SINGLE_PRECISION 
     28#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp)     , INTENT(inout) ::   ptab(f) 
     29#      else 
     30#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp)     , INTENT(inout) ::   ptab(f) 
     31#      endif 
    2032#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    2133#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    … …  
    2436#else 
    2537!                          !==  IN: ptab is an array  ==! 
    26 #   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     38#   if defined SINGLE_PRECISION 
     39#      define ARRAY_TYPE(i,j,k,l,f)    REAL(sp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     40#   else 
     41#      define ARRAY_TYPE(i,j,k,l,f)    REAL(dp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     42#   endif 
    2743#   define NAT_IN(k)                cd_nat 
    2844#   define SGN_IN(k)                psgn 
    … …  
    4561#   endif 
    4662#endif 
     63 
     64# if defined SINGLE_PRECISION 
     65#    define PRECISION sp 
     66#    define SENDROUTINE mppsend_sp 
     67#    define RECVROUTINE mpprecv_sp 
     68#    define MPI_TYPE MPI_REAL 
     69# else 
     70#    define PRECISION dp 
     71#    define SENDROUTINE mppsend_dp 
     72#    define RECVROUTINE mpprecv_dp 
     73#    define MPI_TYPE MPI_DOUBLE_PRECISION 
     74# endif 
    4775 
    4876   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 
    … …  
    6694      INTEGER, DIMENSION(:,:),          ALLOCATABLE ::   jj_s  ! position of sent lines 
    6795      INTEGER, DIMENSION(:),            ALLOCATABLE ::   ipj_s ! number of sent lines 
    68       REAL(wp), DIMENSION(:,:,:)      , ALLOCATABLE ::   ztabl 
    69       REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabr 
    70       REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc, zfoldwk       
    71       REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthgloio 
     96      REAL(PRECISION), DIMENSION(:,:,:)      , ALLOCATABLE ::   ztabl 
     97      REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabr 
     98      REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc, zfoldwk       
     99      REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthgloio 
    72100      !!---------------------------------------------------------------------- 
    73101      ! 
    … …  
    160188         DO jr = 1, nsndto 
    161189            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    162                CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
     190               CALL SENDROUTINE( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    163191            ENDIF 
    164192         END DO 
    … …  
    176204            ENDIF 
    177205            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    178                CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 
     206               CALL RECVROUTINE(5, zfoldwk, ibuffsize, iproc) 
    179207               js = 0 
    180208               DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 
    … …  
    246274         ! start waiting time measurement 
    247275         IF( ln_timing ) CALL tic_tac(.TRUE.) 
    248          CALL MPI_ALLGATHER( znorthloc  , ibuffsize, MPI_DOUBLE_PRECISION,                & 
    249             &                znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     276         CALL MPI_ALLGATHER( znorthloc  , ibuffsize, MPI_TYPE,                & 
     277            &                znorthgloio, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 
    250278         ! 
    251279         ! stop waiting time measurement 
    … …  
    298326   END SUBROUTINE ROUTINE_NFD 
    299327 
     328#undef PRECISION 
     329#undef MPI_TYPE 
     330#undef SENDROUTINE 
     331#undef RECVROUTINE 
    300332#undef ARRAY_TYPE 
    301333#undef NAT_IN 
Note: See TracChangeset for help on using the changeset viewer.