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 10314 for NEMO/branches/2018 – NEMO

Changeset 10314 for NEMO/branches/2018


Ignore:
Timestamp:
2018-11-15T17:27:18+01:00 (5 years ago)
Author:
smasson
Message:

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 2: add generic glob_min/max/sum and locmin/max, complete timing and report (including bdy and icb), see #2133

Location:
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE
Files:
2 added
45 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/ICE/icectl.F90

    r10297 r10314  
    7777      IF( icount == 0 ) THEN 
    7878         !                          ! water flux 
    79          pdiag_fv = glob_sum( -( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) +                  & 
     79         pdiag_fv = glob_sum( 'icectl',                                                                       & 
     80            &                 -( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) +                  & 
    8081            &                    wfx_opw(:,:) + wfx_res(:,:) + wfx_dyn(:,:) + wfx_lam(:,:) + wfx_pnd(:,:)  +  & 
    8182            &                    wfx_snw_sni(:,:) + wfx_snw_sum(:,:) + wfx_snw_dyn(:,:) + wfx_snw_sub(:,:) +  & 
    … …  
    8485         ! 
    8586         !                          ! salt flux 
    86          pdiag_fs = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
     87         pdiag_fs = glob_sum( 'icectl',                                                                     & 
     88            &                  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    8789            &                    sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) + sfx_lam(:,:)    & 
    8890            &                  ) *  e1e2t(:,:) ) * zconv  
    8991         ! 
    9092         !                          ! heat flux 
    91          pdiag_ft = glob_sum(  ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  &  
     93         pdiag_ft = glob_sum( 'icectl',                                                                    & 
     94            &                  ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  &  
    9295            &                  - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:)   & 
    9396            &                  ) *  e1e2t(:,:) ) * zconv 
    9497 
    95          pdiag_v = glob_sum( SUM( v_i * rhoi + v_s * rhos, dim=3 ) * e1e2t * zconv ) 
    96  
    97          pdiag_s = glob_sum( SUM( sv_i * rhoi            , dim=3 ) * e1e2t * zconv ) 
    98  
    99          pdiag_t = glob_sum( (  SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 )     & 
     98         pdiag_v = glob_sum( 'icectl', SUM( v_i * rhoi + v_s * rhos, dim=3 ) * e1e2t * zconv ) 
     99 
     100         pdiag_s = glob_sum( 'icectl', SUM( sv_i * rhoi            , dim=3 ) * e1e2t * zconv ) 
     101 
     102         pdiag_t = glob_sum( 'icectl', (  SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 )     & 
    100103            &                 + SUM( SUM( e_s(:,:,1:nlay_s,:), dim=4 ), dim=3 ) ) * e1e2t ) * zconv 
    101104 
    … …  
    103106 
    104107         ! water flux 
    105          zfv  = glob_sum( -( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) +                  & 
     108         zfv = glob_sum( 'icectl',                                                                        & 
     109            &             -( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) +                  & 
    106110            &                wfx_opw(:,:) + wfx_res(:,:) + wfx_dyn(:,:) + wfx_lam(:,:) + wfx_pnd(:,:)  +  & 
    107111            &                wfx_snw_sni(:,:) + wfx_snw_sum(:,:) + wfx_snw_dyn(:,:) + wfx_snw_sub(:,:) +  & 
    … …  
    110114 
    111115         ! salt flux 
    112          zfs  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
     116         zfs = glob_sum( 'icectl',                                                                       & 
     117            &              ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    113118            &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) + sfx_lam(:,:)    &  
    114119            &              ) * e1e2t(:,:) ) * zconv - pdiag_fs 
    115120 
    116121         ! heat flux 
    117          zft  = glob_sum(  ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  &  
     122         zft = glob_sum( 'icectl',                                                                      & 
     123            &              ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  &  
    118124            &              - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:)   & 
    119125            &              ) * e1e2t(:,:) ) * zconv - pdiag_ft 
    120126  
    121127         ! outputs 
    122          zv = ( ( glob_sum( SUM( v_i * rhoi + v_s * rhos, dim=3 ) * e1e2t ) * zconv  & 
     128         zv = ( ( glob_sum( 'icectl', SUM( v_i * rhoi + v_s * rhos, dim=3 ) * e1e2t ) * zconv  & 
    123129            &     - pdiag_v ) * r1_rdtice - zfv ) * rday 
    124130 
    125          zs = ( ( glob_sum( SUM( sv_i * rhoi            , dim=3 ) * e1e2t ) * zconv  & 
     131         zs = ( ( glob_sum( 'icectl', SUM( sv_i * rhoi            , dim=3 ) * e1e2t ) * zconv  & 
    126132            &     - pdiag_s ) * r1_rdtice + zfs ) * rday 
    127133 
    128          zt = ( glob_sum( (  SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 )   & 
     134         zt = ( glob_sum( 'icectl',                                                                & 
     135            &             (  SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 )                       & 
    129136            &              + SUM( SUM( e_s(:,:,1:nlay_s,:), dim=4 ), dim=3 ) ) * e1e2t ) * zconv   & 
    130137            &   - pdiag_t ) * r1_rdtice + zft 
    131138 
    132139         ! zvtrp and zetrp must be close to 0 if the advection scheme is conservative 
    133          zvtrp = glob_sum( ( diag_trp_vi * rhoi + diag_trp_vs * rhos ) * e1e2t  ) * zconv * rday  
    134          zetrp = glob_sum( ( diag_trp_ei        + diag_trp_es        ) * e1e2t  ) * zconv 
    135  
    136          zvmin = glob_min( v_i ) 
    137          zamax = glob_max( SUM( a_i, dim=3 ) ) 
    138          zamin = glob_min( a_i ) 
     140         zvtrp = glob_sum( 'icectl', ( diag_trp_vi * rhoi + diag_trp_vs * rhos ) * e1e2t  ) * zconv * rday  
     141         zetrp = glob_sum( 'icectl', ( diag_trp_ei        + diag_trp_es        ) * e1e2t  ) * zconv 
     142 
     143         zvmin = glob_min( 'icectl', v_i ) 
     144         zamax = glob_max( 'icectl', SUM( a_i, dim=3 ) ) 
     145         zamin = glob_min( 'icectl', a_i ) 
    139146 
    140147         ! set threshold values and calculate the ice area (+epsi10 to set a threshold > 0 when there is no ice)  
    141          zarea   = glob_sum( SUM( a_i + epsi10, dim=3 ) * e1e2t ) * zconv ! in 1.e9 m2 
     148         zarea   = glob_sum( 'icectl', SUM( a_i + epsi10, dim=3 ) * e1e2t ) * zconv ! in 1.e9 m2 
    142149         zv_sill = zarea * 2.5e-5 
    143150         zs_sill = zarea * 25.e-5 
    … …  
    184191 
    185192      ! water flux 
    186       zvfx  = glob_sum( ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + diag_vice + diag_vsnw ) * e1e2t ) * zconv * rday 
     193      zvfx  = glob_sum( 'icectl', ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + diag_vice + diag_vsnw ) * e1e2t ) * zconv * rday 
    187194 
    188195      ! salt flux 
    189       zsfx  = glob_sum( ( sfx + diag_sice ) * e1e2t ) * zconv * rday 
     196      zsfx  = glob_sum( 'icectl', ( sfx + diag_sice ) * e1e2t ) * zconv * rday 
    190197 
    191198      ! heat flux 
    192       zhfx  = glob_sum( ( qt_atm_oi - qt_oce_ai - diag_heat - diag_trp_ei - diag_trp_es   & 
     199      zhfx  = glob_sum( 'icectl', ( qt_atm_oi - qt_oce_ai - diag_heat - diag_trp_ei - diag_trp_es   & 
    193200      !  &              - SUM( qevap_ice * a_i_b, dim=3 )                           & !!clem: I think this line must be commented (but need check) 
    194201         &              ) * e1e2t ) * zconv 
    195202 
    196203      ! set threshold values and calculate the ice area (+epsi10 to set a threshold > 0 when there is no ice)  
    197       zarea   = glob_sum( SUM( a_i + epsi10, dim=3 ) * e1e2t ) * zconv ! in 1.e9 m2 
     204      zarea   = glob_sum( 'icectl', SUM( a_i + epsi10, dim=3 ) * e1e2t ) * zconv ! in 1.e9 m2 
    198205      zv_sill = zarea * 2.5e-5 
    199206      zs_sill = zarea * 25.e-5 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/ICE/icedia.F90

    r10297 r10314  
    8585      ! 1 -  Contents ! 
    8686      ! ----------------------- ! 
    87       zbg_ivol = glob_sum( vt_i(:,:) * e1e2t(:,:) ) * 1.e-9                  ! ice volume (km3) 
    88       zbg_svol = glob_sum( vt_s(:,:) * e1e2t(:,:) ) * 1.e-9                  ! snow volume (km3) 
    89       zbg_area = glob_sum( at_i(:,:) * e1e2t(:,:) ) * 1.e-6                  ! area (km2) 
    90       zbg_isal = glob_sum( SUM( sv_i(:,:,:), dim=3 ) * e1e2t(:,:) ) * 1.e-9 ! salt content (pss*km3) 
    91       zbg_item = glob_sum( et_i * e1e2t(:,:) ) * 1.e-20                      ! heat content (1.e20 J) 
    92       zbg_stem = glob_sum( et_s * e1e2t(:,:) ) * 1.e-20                      ! heat content (1.e20 J) 
     87      zbg_ivol = glob_sum( 'icedia', vt_i(:,:) * e1e2t(:,:) ) * 1.e-9                  ! ice volume (km3) 
     88      zbg_svol = glob_sum( 'icedia', vt_s(:,:) * e1e2t(:,:) ) * 1.e-9                  ! snow volume (km3) 
     89      zbg_area = glob_sum( 'icedia', at_i(:,:) * e1e2t(:,:) ) * 1.e-6                  ! area (km2) 
     90      zbg_isal = glob_sum( 'icedia', SUM( sv_i(:,:,:), dim=3 ) * e1e2t(:,:) ) * 1.e-9 ! salt content (pss*km3) 
     91      zbg_item = glob_sum( 'icedia', et_i * e1e2t(:,:) ) * 1.e-20                      ! heat content (1.e20 J) 
     92      zbg_stem = glob_sum( 'icedia', et_s * e1e2t(:,:) ) * 1.e-20                      ! heat content (1.e20 J) 
    9393       
    9494      ! ---------------------------! 
    9595      ! 2 - Trends due to forcing  ! 
    9696      ! ---------------------------! 
    97       z_frc_volbot = r1_rau0 * glob_sum( - ( wfx_ice(:,:) + wfx_snw(:,:) + wfx_err_sub(:,:) ) * e1e2t(:,:) ) * 1.e-9   ! freshwater flux ice/snow-ocean  
    98       z_frc_voltop = r1_rau0 * glob_sum( - ( wfx_sub(:,:) + wfx_spr(:,:) )                    * e1e2t(:,:) ) * 1.e-9   ! freshwater flux ice/snow-atm 
    99       z_frc_sal    = r1_rau0 * glob_sum( -       sfx(:,:)                                     * e1e2t(:,:) ) * 1.e-9   ! salt fluxes ice/snow-ocean 
    100       z_frc_tembot =           glob_sum(   qt_oce_ai(:,:)                                     * e1e2t(:,:) ) * 1.e-20  ! heat on top of ocean (and below ice) 
    101       z_frc_temtop =           glob_sum(   qt_atm_oi(:,:)                                     * e1e2t(:,:) ) * 1.e-20  ! heat on top of ice-coean 
     97      z_frc_volbot = r1_rau0 * glob_sum( 'icedia', -( wfx_ice(:,:) + wfx_snw(:,:) + wfx_err_sub(:,:) ) * e1e2t(:,:) ) * 1.e-9   ! freshwater flux ice/snow-ocean  
     98      z_frc_voltop = r1_rau0 * glob_sum( 'icedia', -( wfx_sub(:,:) + wfx_spr(:,:) )                    * e1e2t(:,:) ) * 1.e-9   ! freshwater flux ice/snow-atm 
     99      z_frc_sal    = r1_rau0 * glob_sum( 'icedia', -      sfx(:,:)                                     * e1e2t(:,:) ) * 1.e-9   ! salt fluxes ice/snow-ocean 
     100      z_frc_tembot =           glob_sum( 'icedia',  qt_oce_ai(:,:)                                     * e1e2t(:,:) ) * 1.e-20  ! heat on top of ocean (and below ice) 
     101      z_frc_temtop =           glob_sum( 'icedia',  qt_atm_oi(:,:)                                     * e1e2t(:,:) ) * 1.e-20  ! heat on top of ice-coean 
    102102      ! 
    103103      frc_voltop  = frc_voltop  + z_frc_voltop  * rdt_ice ! km3 
    … …  
    110110      ! 3 -  Content variations ! 
    111111      ! ----------------------- ! 
    112       zdiff_vol = r1_rau0 * glob_sum( ( rhoi*vt_i(:,:) + rhos*vt_s(:,:) - vol_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9   ! freshwater trend (km3)  
    113       zdiff_sal = r1_rau0 * glob_sum( ( rhoi* SUM( sv_i(:,:,:), dim=3 ) - sal_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9   ! salt content trend (km3*pss) 
    114       zdiff_tem =           glob_sum( ( et_i(:,:) + et_s(:,:)           - tem_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-20  ! heat content trend (1.e20 J) 
     112      zdiff_vol = r1_rau0 * glob_sum( 'icedia', ( rhoi*vt_i(:,:) + rhos*vt_s(:,:) - vol_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9   ! freshwater trend (km3)  
     113      zdiff_sal = r1_rau0 * glob_sum( 'icedia', ( rhoi* SUM( sv_i(:,:,:), dim=3 ) - sal_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9   ! salt content trend (km3*pss) 
     114      zdiff_tem =           glob_sum( 'icedia', ( et_i(:,:) + et_s(:,:)           - tem_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-20  ! heat content trend (1.e20 J) 
    115115      !                               + SUM( qevap_ice * a_i_b, dim=3 )       !! clem: I think this term should not be there (but needs a check) 
    116116 
    … …  
    125125      ! 5 - Diagnostics writing ! 
    126126      ! ----------------------- ! 
    127 !!gm I don't understand the division by the ocean surface (i.e. glob_sum( e1e2t(:,:) ) * 1.e-20 * kt*rdt ) 
     127!!gm I don't understand the division by the ocean surface (i.e. glob_sum( 'icedia', e1e2t(:,:) ) * 1.e-20 * kt*rdt ) 
    128128!!   and its multiplication bu kt ! is it really what we want ? what is this quantity ? 
    129129!!   IF it is really what we want, compute it at kt=nit000, not 3 time by time-step ! 
    … …  
    135135      IF( iom_use('ibgheatco')    )   CALL iom_put( 'ibgheatco' , zdiff_tem     )   ! ice/snow heat content drift       (1.e20 J) 
    136136      IF( iom_use('ibgheatfx')    )   CALL iom_put( 'ibgheatfx' ,               &   ! ice/snow heat flux drift          (W/m2) 
    137          &                                                     zdiff_tem /glob_sum( e1e2t(:,:) * 1.e-20 * kt*rdt ) ) 
     137         &                                                     zdiff_tem /glob_sum( 'icedia', e1e2t(:,:) * 1.e-20 * kt*rdt ) ) 
    138138 
    139139      IF( iom_use('ibgfrcvoltop') )   CALL iom_put( 'ibgfrcvoltop' , frc_voltop )   ! vol  forcing ice/snw-atm          (km3 equivalent ocean water)  
    … …  
    143143      IF( iom_use('ibgfrctembot') )   CALL iom_put( 'ibgfrctembot' , frc_tembot )   ! heat on top of ocean(below ice)   (1.e20 J)    
    144144      IF( iom_use('ibgfrchfxtop') )   CALL iom_put( 'ibgfrchfxtop' ,            &   ! heat on top of ice/snw/ocean      (W/m2)  
    145          &                                                          frc_temtop / glob_sum( e1e2t(:,:) ) * 1.e-20 * kt*rdt  ) 
     145         &                                                          frc_temtop / glob_sum( 'icedia', e1e2t(:,:) ) * 1.e-20 * kt*rdt  ) 
    146146      IF( iom_use('ibgfrchfxbot') )   CALL iom_put( 'ibgfrchfxbot' ,            &   ! heat on top of ocean(below ice)   (W/m2)  
    147          &                                                          frc_tembot / glob_sum( e1e2t(:,:) ) * 1.e-20 * kt*rdt  ) 
     147         &                                                          frc_tembot / glob_sum( 'icedia', e1e2t(:,:) ) * 1.e-20 * kt*rdt  ) 
    148148 
    149149      IF( iom_use('ibgvol_tot' )  )   CALL iom_put( 'ibgvol_tot'  , zbg_ivol     )   ! ice volume                       (km3) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/ICE/icewri.F90

    r10170 r10314  
    184184         ELSEWHERE               ;   zmsk00(:,:) = 0. 
    185185         END WHERE  
    186          zdiag_area_nh = glob_sum( at_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 
    187          zdiag_volu_nh = glob_sum( vt_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 
     186         zdiag_area_nh = glob_sum( 'icewri', at_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 
     187         zdiag_volu_nh = glob_sum( 'icewri', vt_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 
    188188         ! 
    189189         WHERE( ff_t > 0._wp .AND. at_i > 0.15 )   ; zmsk00(:,:) = 1.0e-12 
    190190         ELSEWHERE                                 ; zmsk00(:,:) = 0. 
    191191         END WHERE  
    192          zdiag_extt_nh = glob_sum( zmsk00(:,:) * e1e2t(:,:) ) 
     192         zdiag_extt_nh = glob_sum( 'icewri', zmsk00(:,:) * e1e2t(:,:) ) 
    193193         ! 
    194194         IF( iom_use('NH_icearea') )   CALL iom_put( "NH_icearea" ,  zdiag_area_nh ) 
    … …  
    203203         ELSEWHERE            ; zmsk00(:,:) = 0. 
    204204         END WHERE  
    205          zdiag_area_sh = glob_sum( at_i(:,:) * zmsk00(:,:) * e1e2t(:,:) )  
    206          zdiag_volu_sh = glob_sum( vt_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 
     205         zdiag_area_sh = glob_sum( 'icewri', at_i(:,:) * zmsk00(:,:) * e1e2t(:,:) )  
     206         zdiag_volu_sh = glob_sum( 'icewri', vt_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 
    207207         ! 
    208208         WHERE( ff_t < 0._wp .AND. at_i > 0.15 ); zmsk00(:,:) = 1.0e-12 
    209209         ELSEWHERE                              ; zmsk00(:,:) = 0. 
    210210         END WHERE  
    211          zdiag_extt_sh = glob_sum( zmsk00(:,:) * e1e2t(:,:) ) 
     211         zdiag_extt_sh = glob_sum( 'icewri', zmsk00(:,:) * e1e2t(:,:) ) 
    212212         ! 
    213213         IF( iom_use('SH_icearea') ) CALL iom_put( "SH_icearea", zdiag_area_sh ) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/BDY/bdydyn2d.F90

    r10068 r10314  
    109109         pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) 
    110110      END DO  
    111       CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy )  
    112       CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy)   ! Boundary points should be updated 
     111      CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )  
     112      CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy)   ! Boundary points should be updated 
    113113      ! 
    114114   END SUBROUTINE bdy_dyn2d_frs 
    … …  
    169169      END DO 
    170170 
    171       CALL lbc_bdy_lnk( spgu(:,:), 'T', 1., ib_bdy ) 
     171      CALL lbc_bdy_lnk( 'bdydyn2d', spgu(:,:), 'T', 1., ib_bdy ) 
    172172      ! 
    173173      igrd = 2      ! Flather bc on u-velocity;  
    … …  
    207207         pva2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * vmask(ii,ij,1) 
    208208      END DO 
    209       CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
    210       CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy )   ! 
     209      CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
     210      CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy )   ! 
    211211      ! 
    212212   END SUBROUTINE bdy_dyn2d_fla 
    … …  
    243243      CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, ll_npo ) 
    244244      ! 
    245       CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
    246       CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy )   ! 
     245      CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
     246      CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy )   ! 
    247247      ! 
    248248   END SUBROUTINE bdy_dyn2d_orlanski 
    … …  
    291291 
    292292         ! Boundary points should be updated 
    293          CALL lbc_bdy_lnk( zssh(:,:), 'T', 1., ib_bdy ) 
     293         CALL lbc_bdy_lnk( 'bdydyn2d', zssh(:,:), 'T', 1., ib_bdy ) 
    294294      END DO 
    295295 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/BDY/bdydyn3d.F90

    r10170 r10314  
    9797         END DO 
    9898      END DO 
    99       CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
    100       CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )    
     99      CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
     100      CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    101101      ! 
    102102      IF( kt == nit000 )   CLOSE( unit = 102 ) 
    … …  
    144144         END DO 
    145145      END DO 
    146       CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
    147       CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )    
     146      CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
     147      CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    148148      ! 
    149149      IF( kt == nit000 )   CLOSE( unit = 102 ) 
    … …  
    187187      END DO 
    188188      ! 
    189       CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy )   ! Boundary points should be updated 
     189      CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1.,ib_bdy )   ! Boundary points should be updated 
    190190      ! 
    191191      IF( kt == nit000 )   CLOSE( unit = 102 ) 
    … …  
    234234         END DO 
    235235      END DO  
    236       CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    237       CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )    
     236      CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
     237      CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    238238      ! 
    239239      IF( kt == nit000 )   CLOSE( unit = 102 ) 
    … …  
    270270      CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo ) 
    271271      ! 
    272       CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    273       CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )    
     272      CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
     273      CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    274274      ! 
    275275   END SUBROUTINE bdy_dyn3d_orlanski 
    … …  
    351351      CALL bdy_nmn( idx, igrd, va ) 
    352352      ! 
    353       CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    354       CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy ) 
     353      CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
     354      CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 
    355355      ! 
    356356   END SUBROUTINE bdy_dyn3d_nmn 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/BDY/bdyice.F90

    r10069 r10314  
    135135         ENDDO 
    136136      ENDDO 
    137       CALL lbc_bdy_lnk( a_i(:,:,:), 'T', 1., jbdy ) 
    138       CALL lbc_bdy_lnk( h_i(:,:,:), 'T', 1., jbdy ) 
    139       CALL lbc_bdy_lnk( h_s(:,:,:), 'T', 1., jbdy ) 
     137      CALL lbc_bdy_lnk( 'bdyice', a_i(:,:,:), 'T', 1., jbdy ) 
     138      CALL lbc_bdy_lnk( 'bdyice', h_i(:,:,:), 'T', 1., jbdy ) 
     139      CALL lbc_bdy_lnk( 'bdyice', h_s(:,:,:), 'T', 1., jbdy ) 
    140140 
    141141      DO jl = 1, jpl 
    … …  
    244244      END DO ! jl 
    245245 
    246       CALL lbc_bdy_lnk( a_i (:,:,:)  , 'T', 1., jbdy ) 
    247       CALL lbc_bdy_lnk( h_i (:,:,:)  , 'T', 1., jbdy ) 
    248       CALL lbc_bdy_lnk( h_s (:,:,:)  , 'T', 1., jbdy ) 
    249       CALL lbc_bdy_lnk( oa_i(:,:,:)  , 'T', 1., jbdy ) 
    250       CALL lbc_bdy_lnk( a_ip(:,:,:)  , 'T', 1., jbdy ) 
    251       CALL lbc_bdy_lnk( v_ip(:,:,:)  , 'T', 1., jbdy ) 
    252       CALL lbc_bdy_lnk( s_i (:,:,:)  , 'T', 1., jbdy ) 
    253       CALL lbc_bdy_lnk( t_su(:,:,:)  , 'T', 1., jbdy ) 
    254       CALL lbc_bdy_lnk( v_i (:,:,:)  , 'T', 1., jbdy ) 
    255       CALL lbc_bdy_lnk( v_s (:,:,:)  , 'T', 1., jbdy ) 
    256       CALL lbc_bdy_lnk( sv_i(:,:,:)  , 'T', 1., jbdy ) 
    257       CALL lbc_bdy_lnk( t_s (:,:,:,:), 'T', 1., jbdy ) 
    258       CALL lbc_bdy_lnk( e_s (:,:,:,:), 'T', 1., jbdy ) 
    259       CALL lbc_bdy_lnk( t_i (:,:,:,:), 'T', 1., jbdy ) 
    260       CALL lbc_bdy_lnk( e_i (:,:,:,:), 'T', 1., jbdy ) 
     246      CALL lbc_bdy_lnk( 'bdyice', a_i (:,:,:)  , 'T', 1., jbdy ) 
     247      CALL lbc_bdy_lnk( 'bdyice', h_i (:,:,:)  , 'T', 1., jbdy ) 
     248      CALL lbc_bdy_lnk( 'bdyice', h_s (:,:,:)  , 'T', 1., jbdy ) 
     249      CALL lbc_bdy_lnk( 'bdyice', oa_i(:,:,:)  , 'T', 1., jbdy ) 
     250      CALL lbc_bdy_lnk( 'bdyice', a_ip(:,:,:)  , 'T', 1., jbdy ) 
     251      CALL lbc_bdy_lnk( 'bdyice', v_ip(:,:,:)  , 'T', 1., jbdy ) 
     252      CALL lbc_bdy_lnk( 'bdyice', s_i (:,:,:)  , 'T', 1., jbdy ) 
     253      CALL lbc_bdy_lnk( 'bdyice', t_su(:,:,:)  , 'T', 1., jbdy ) 
     254      CALL lbc_bdy_lnk( 'bdyice', v_i (:,:,:)  , 'T', 1., jbdy ) 
     255      CALL lbc_bdy_lnk( 'bdyice', v_s (:,:,:)  , 'T', 1., jbdy ) 
     256      CALL lbc_bdy_lnk( 'bdyice', sv_i(:,:,:)  , 'T', 1., jbdy ) 
     257      CALL lbc_bdy_lnk( 'bdyice', t_s (:,:,:,:), 'T', 1., jbdy ) 
     258      CALL lbc_bdy_lnk( 'bdyice', e_s (:,:,:,:), 'T', 1., jbdy ) 
     259      CALL lbc_bdy_lnk( 'bdyice', t_i (:,:,:,:), 'T', 1., jbdy ) 
     260      CALL lbc_bdy_lnk( 'bdyice', e_i (:,:,:,:), 'T', 1., jbdy ) 
    261261      !       
    262262   END SUBROUTINE bdy_ice_frs 
    … …  
    317317                  ! 
    318318               END DO 
    319                CALL lbc_bdy_lnk( u_ice(:,:), 'U', -1., jbdy ) 
     319               CALL lbc_bdy_lnk( 'bdyice', u_ice(:,:), 'U', -1., jbdy ) 
    320320               ! 
    321321            CASE ( 'V' ) 
    … …  
    340340                  ! 
    341341               END DO 
    342                CALL lbc_bdy_lnk( v_ice(:,:), 'V', -1., jbdy ) 
     342               CALL lbc_bdy_lnk( 'bdyice', v_ice(:,:), 'V', -1., jbdy ) 
    343343               ! 
    344344            END SELECT 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/BDY/bdytra.F90

    r10068 r10314  
    7171            END SELECT 
    7272            ! Boundary points should be updated 
    73             CALL lbc_bdy_lnk( tsa(:,:,:,jn), 'T', 1., ib_bdy ) 
     73            CALL lbc_bdy_lnk( 'bdytra', tsa(:,:,:,jn), 'T', 1., ib_bdy ) 
    7474            !  
    7575         END DO 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/BDY/bdyvol.F90

    r10297 r10314  
    8787      IF( lk_mpp )   CALL mpp_sum( 'bdyvol', z_cflxemp )     ! sum over the global domain 
    8888!!gm   by : 
    89 !!gm      z_cflxemp = glob_sum(  ( emp(:,:)-rnf(:,:)+fwfisf(:,:) ) * bdytmask(:,:) * e1e2t(:,:)  ) / rau0 
     89!!gm      z_cflxemp = glob_sum(  'bdyvol', ( emp(:,:)-rnf(:,:)+fwfisf(:,:) ) * bdytmask(:,:) * e1e2t(:,:)  ) / rau0 
    9090!!gm 
    9191 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/DIA/diacfl.F90

    r10068 r10314  
    5454      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    5555      ! 
    56       INTEGER :: ji, jj, jk   ! dummy loop indices 
    57       REAL(wp)::   z2dt, zCu_max, zCv_max, zCw_max       ! local scalars 
    58       INTEGER , DIMENSION(3)           ::   iloc_u , iloc_v , iloc_w , iloc   ! workspace 
     56      INTEGER                ::   ji, jj, jk                            ! dummy loop indices 
     57      REAL(wp)               ::   z2dt, zCu_max, zCv_max, zCw_max       ! local scalars 
     58      INTEGER , DIMENSION(3) ::   iloc_u , iloc_v , iloc_w , iloc       ! workspace 
    5959!!gm this does not work      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zCu_cfl, zCv_cfl, zCw_cfl         ! workspace 
    6060      !!---------------------------------------------------------------------- 
    … …  
    8080      !                    ! calculate maximum values and locations 
    8181      IF( lk_mpp ) THEN 
    82          CALL mpp_maxloc( zCu_cfl, umask, zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) ) 
    83          CALL mpp_maxloc( zCv_cfl, vmask, zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) ) 
    84          CALL mpp_maxloc( zCw_cfl, wmask, zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) ) 
     82         CALL mpp_maxloc( 'diacfl', zCu_cfl, umask, zCu_max, iloc_u ) 
     83         CALL mpp_maxloc( 'diacfl', zCv_cfl, vmask, zCv_max, iloc_v ) 
     84         CALL mpp_maxloc( 'diacfl', zCw_cfl, wmask, zCw_max, iloc_w ) 
    8585      ELSE 
    8686         iloc = MAXLOC( ABS( zcu_cfl(:,:,:) ) ) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/DIA/diahsb.F90

    r10068 r10314  
    9191      ! 1 - Trends due to forcing ! 
    9292      ! ------------------------- ! 
    93       z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * surf(:,:) )   ! volume fluxes 
    94       z_frc_trd_t =           glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) )                       ! heat fluxes 
    95       z_frc_trd_s =           glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) )                       ! salt fluxes 
     93      z_frc_trd_v = r1_rau0 * glob_sum( 'diahsb', - ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * surf(:,:) )   ! volume fluxes 
     94      z_frc_trd_t =           glob_sum( 'diahsb', sbc_tsc(:,:,jp_tem) * surf(:,:) )                       ! heat fluxes 
     95      z_frc_trd_s =           glob_sum( 'diahsb', sbc_tsc(:,:,jp_sal) * surf(:,:) )                       ! salt fluxes 
    9696      !                    !  Add runoff    heat & salt input 
    97       IF( ln_rnf    )   z_frc_trd_t = z_frc_trd_t + glob_sum( rnf_tsc(:,:,jp_tem) * surf(:,:) ) 
    98       IF( ln_rnf_sal)   z_frc_trd_s = z_frc_trd_s + glob_sum( rnf_tsc(:,:,jp_sal) * surf(:,:) ) 
     97      IF( ln_rnf    )   z_frc_trd_t = z_frc_trd_t + glob_sum( 'diahsb', rnf_tsc(:,:,jp_tem) * surf(:,:) ) 
     98      IF( ln_rnf_sal)   z_frc_trd_s = z_frc_trd_s + glob_sum( 'diahsb', rnf_tsc(:,:,jp_sal) * surf(:,:) ) 
    9999      !                    ! Add ice shelf heat & salt input 
    100       IF( ln_isf    )   z_frc_trd_t = z_frc_trd_t + glob_sum( risf_tsc(:,:,jp_tem) * surf(:,:) ) 
     100      IF( ln_isf    )   z_frc_trd_t = z_frc_trd_t + glob_sum( 'diahsb', risf_tsc(:,:,jp_tem) * surf(:,:) ) 
    101101      !                    ! Add penetrative solar radiation 
    102       IF( ln_traqsr )   z_frc_trd_t = z_frc_trd_t + r1_rau0_rcp * glob_sum( qsr     (:,:) * surf(:,:) ) 
     102      IF( ln_traqsr )   z_frc_trd_t = z_frc_trd_t + r1_rau0_rcp * glob_sum( 'diahsb', qsr     (:,:) * surf(:,:) ) 
    103103      !                    ! Add geothermal heat flux 
    104       IF( ln_trabbc )   z_frc_trd_t = z_frc_trd_t +               glob_sum( qgh_trd0(:,:) * surf(:,:) ) 
     104      IF( ln_trabbc )   z_frc_trd_t = z_frc_trd_t +               glob_sum( 'diahsb', qgh_trd0(:,:) * surf(:,:) ) 
    105105      ! 
    106106      IF( ln_linssh ) THEN 
    … …  
    116116            z2d1(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_sal) 
    117117         END IF 
    118          z_wn_trd_t = - glob_sum( z2d0 )  
    119          z_wn_trd_s = - glob_sum( z2d1 ) 
     118         z_wn_trd_t = - glob_sum( 'diahsb', z2d0 )  
     119         z_wn_trd_s = - glob_sum( 'diahsb', z2d1 ) 
    120120      ENDIF 
    121121 
    … …  
    135135 
    136136      !                    ! volume variation (calculated with ssh) 
    137       zdiff_v1 = glob_sum_full( surf(:,:)*sshn(:,:) - surf_ini(:,:)*ssh_ini(:,:) ) 
     137      zdiff_v1 = glob_sum_full( 'diahsb', surf(:,:)*sshn(:,:) - surf_ini(:,:)*ssh_ini(:,:) ) 
    138138 
    139139      !                    ! heat & salt content variation (associated with ssh) 
    … …  
    150150            z2d1(:,:) = surf(:,:) * ( tsn(:,:,1,jp_sal) * sshn(:,:) - ssh_sc_loc_ini(:,:) )  
    151151         END IF 
    152          z_ssh_hc = glob_sum_full( z2d0 )  
    153          z_ssh_sc = glob_sum_full( z2d1 )  
    154       ENDIF 
    155       ! 
    156       DO jk = 1, jpkm1     ! volume variation (calculated with scale factors) 
     152         z_ssh_hc = glob_sum_full( 'diahsb', z2d0 )  
     153         z_ssh_sc = glob_sum_full( 'diahsb', z2d1 )  
     154      ENDIF 
     155      ! 
     156      DO jk = 1, jpkm1           ! volume variation (calculated with scale factors) 
    157157         zwrk(:,:,jk) = ( surf(:,:)*e3t_n(:,:,jk) - surf_ini(:,:)*e3t_ini(:,:,jk) ) * tmask(:,:,jk) 
    158158      END DO 
    159       zdiff_v2 = glob_sum_full( zwrk(:,:,:) ) 
     159      zdiff_v2 = glob_sum_full( 'diahsb', zwrk(:,:,:) ) 
    160160      DO jk = 1, jpkm1           ! heat content variation 
    161161         zwrk(:,:,jk) = ( surf(:,:)*e3t_n(:,:,jk)*tsn(:,:,jk,jp_tem) - surf_ini(:,:)*hc_loc_ini(:,:,jk) ) * tmask(:,:,jk) 
    162162      END DO 
    163       zdiff_hc = glob_sum_full( zwrk(:,:,:) ) 
     163      zdiff_hc = glob_sum_full( 'diahsb', zwrk(:,:,:) ) 
    164164      DO jk = 1, jpkm1           ! salt content variation 
    165165         zwrk(:,:,jk) = ( surf(:,:)*e3t_n(:,:,jk)*tsn(:,:,jk,jp_sal) - surf_ini(:,:)*sc_loc_ini(:,:,jk) ) * tmask(:,:,jk) 
    166166      END DO 
    167       zdiff_sc = glob_sum_full( zwrk(:,:,:) ) 
     167      zdiff_sc = glob_sum_full( 'diahsb', zwrk(:,:,:) ) 
    168168 
    169169      ! ------------------------ ! 
    … …  
    187187         zwrk(:,:,jk) = surf(:,:) * e3t_n(:,:,jk) * tmask(:,:,jk) 
    188188      END DO 
    189       zvol_tot = glob_sum_full( zwrk(:,:,:) ) 
     189      zvol_tot = glob_sum_full( 'diahsb', zwrk(:,:,:) ) 
    190190 
    191191!!gm to be added ? 
    192192!      IF( ln_linssh ) THEN            ! fixed volume, add the ssh contribution 
    193 !        zvol_tot = zvol_tot + glob_sum( surf(:,:) * sshn(:,:) ) 
     193!        zvol_tot = zvol_tot + glob_sum( 'diahsb', surf(:,:) * sshn(:,:) ) 
    194194!      ENDIF 
    195195!!gm end 
    … …  
    409409      ! 2 - Time independant variables and file opening ! 
    410410      ! ----------------------------------------------- ! 
    411       surf(:,:) = e1e2t(:,:) * tmask_i(:,:)     ! masked surface grid cell area 
    412       surf_tot  = glob_sum( surf(:,:) )         ! total ocean surface area 
     411      surf(:,:) = e1e2t(:,:) * tmask_i(:,:)               ! masked surface grid cell area 
     412      surf_tot  = glob_sum( 'diahsb', surf(:,:) )         ! total ocean surface area 
    413413 
    414414      IF( ln_bdy ) CALL ctl_warn( 'dia_hsb_init: heat/salt budget does not consider open boundary fluxes' )          

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/DOM/closea.F90

    r10297 r10314  
    237237         surfe(:) = 0.e0_wp 
    238238         ! 
    239          surf(jncs+1) = glob_sum( e1e2t(:,:) )   ! surface of the global ocean 
     239         surf(jncs+1) = glob_sum( 'closea', e1e2t(:,:) )   ! surface of the global ocean 
    240240         ! 
    241241         !                                        ! surface areas of closed seas  
    … …  
    243243            ztmp2d(:,:) = 0.e0_wp 
    244244            WHERE( closea_mask(:,:) == jc ) ztmp2d(:,:) = e1e2t(:,:) * tmask_i(:,:) 
    245             surf(jc) = glob_sum( ztmp2d(:,:) ) 
     245            surf(jc) = glob_sum( 'closea', ztmp2d(:,:) ) 
    246246         END DO 
    247247         ! 
    … …  
    254254               ztmp2d(:,:) = 0.e0_wp 
    255255               WHERE( closea_mask_rnf(:,:) == jcr .and. closea_mask(:,:) == 0 ) ztmp2d(:,:) = e1e2t(:,:) * tmask_i(:,:) 
    256                surfr(jcr) = glob_sum( ztmp2d(:,:) ) 
     256               surfr(jcr) = glob_sum( 'closea', ztmp2d(:,:) ) 
    257257            END DO 
    258258         ENDIF 
    … …  
    263263               ztmp2d(:,:) = 0.e0_wp 
    264264               WHERE( closea_mask_empmr(:,:) == jce .and. closea_mask(:,:) == 0 ) ztmp2d(:,:) = e1e2t(:,:) * tmask_i(:,:) 
    265                surfe(jce) = glob_sum( ztmp2d(:,:) ) 
     265               surfe(jce) = glob_sum( 'closea', ztmp2d(:,:) ) 
    266266            END DO 
    267267         ENDIF 
    … …  
    301301         ztmp2d(:,:) = 0.e0_wp 
    302302         WHERE( closea_mask(:,:) == jc ) ztmp2d(:,:) = e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * tmask_i(:,:) 
    303          zfwf(jc) = glob_sum( ztmp2d(:,:) ) 
     303         zfwf(jc) = glob_sum( 'closea', ztmp2d(:,:) ) 
    304304      END DO 
    305305      zfwf_total = SUM(zfwf) 
    … …  
    316316            ztmp2d(:,:) = 0.e0_wp 
    317317            WHERE( closea_mask_rnf(:,:) == jcr .and. closea_mask(:,:) > 0 ) ztmp2d(:,:) = e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * tmask_i(:,:) 
    318             zfwfr(jcr) = glob_sum( ztmp2d(:,:) ) 
     318            zfwfr(jcr) = glob_sum( 'closea', ztmp2d(:,:) ) 
    319319            ! 
    320320            ! The following if avoids the redistribution of the round off 
    … …  
    345345            ztmp2d(:,:) = 0.e0_wp 
    346346            WHERE( closea_mask_empmr(:,:) == jce .and. closea_mask(:,:) > 0 ) ztmp2d(:,:) = e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * tmask_i(:,:) 
    347             zfwfe(jce) = glob_sum( ztmp2d(:,:) ) 
     347            zfwfe(jce) = glob_sum( 'closea', ztmp2d(:,:) ) 
    348348            ! 
    349349            ! The following if avoids the redistribution of the round off 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/DOM/domain.F90

    r10068 r10314  
    469469      !! ** Method  :   compute and print extrema of masked scale factors 
    470470      !!---------------------------------------------------------------------- 
    471       INTEGER ::   iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2 
     471      INTEGER, DIMENSION(2) ::   imi1, imi2, ima1, ima2 
    472472      INTEGER, DIMENSION(2) ::   iloc   !  
    473473      REAL(wp) ::   ze1min, ze1max, ze2min, ze2max 
    … …  
    475475      ! 
    476476      IF(lk_mpp) THEN 
    477          CALL mpp_minloc( e1t(:,:), tmask_i(:,:), ze1min, iimi1,ijmi1 ) 
    478          CALL mpp_minloc( e2t(:,:), tmask_i(:,:), ze2min, iimi2,ijmi2 ) 
    479          CALL mpp_maxloc( e1t(:,:), tmask_i(:,:), ze1max, iima1,ijma1 ) 
    480          CALL mpp_maxloc( e2t(:,:), tmask_i(:,:), ze2max, iima2,ijma2 ) 
     477         CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 ) 
     478         CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 ) 
     479         CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 ) 
     480         CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 
    481481      ELSE 
    482482         ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )     
    … …  
    486486         ! 
    487487         iloc  = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    488          iimi1 = iloc(1) + nimpp - 1 
    489          ijmi1 = iloc(2) + njmpp - 1 
     488         imi1(1) = iloc(1) + nimpp - 1 
     489         imi1(2) = iloc(2) + njmpp - 1 
    490490         iloc  = MINLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    491          iimi2 = iloc(1) + nimpp - 1 
    492          ijmi2 = iloc(2) + njmpp - 1 
     491         imi2(1) = iloc(1) + nimpp - 1 
     492         imi2(2) = iloc(2) + njmpp - 1 
    493493         iloc  = MAXLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    494          iima1 = iloc(1) + nimpp - 1 
    495          ijma1 = iloc(2) + njmpp - 1 
     494         ima1(1) = iloc(1) + nimpp - 1 
     495         ima1(2) = iloc(2) + njmpp - 1 
    496496         iloc  = MAXLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    497          iima2 = iloc(1) + nimpp - 1 
    498          ijma2 = iloc(2) + njmpp - 1 
     497         ima2(1) = iloc(1) + nimpp - 1 
     498         ima2(2) = iloc(2) + njmpp - 1 
    499499      ENDIF 
    500500      IF(lwp) THEN 
    … …  
    502502         WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' 
    503503         WRITE(numout,*) '~~~~~~~' 
    504          WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, iima1, ijma1 
    505          WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1 
    506          WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2 
    507          WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2 
     504         WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) 
     505         WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) 
     506         WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) 
     507         WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) 
    508508      ENDIF 
    509509      ! 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/DOM/domngb.F90

    r10068 r10314  
    6767       
    6868      IF( lk_mpp ) THEN   
    69          CALL mpp_minloc( zdist(:,:), zmask, zmini, kii, kjj) 
     69         CALL mpp_minloc( 'domngb', zdist(:,:), zmask, zmini, iloc) 
     70         kii = iloc(1) ; kjj = iloc(2) 
    7071      ELSE 
    7172         iloc(:) = MINLOC( zdist(:,:), mask = zmask(:,:) == 1.e0 ) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/DOM/domvvl.F90

    r10297 r10314  
    435435         IF( ( z_tmax >  rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN 
    436436            IF( lk_mpp ) THEN 
    437                CALL mpp_maxloc( ze3t, tmask, z_tmax, ijk_max(1), ijk_max(2), ijk_max(3) ) 
    438                CALL mpp_minloc( ze3t, tmask, z_tmin, ijk_min(1), ijk_min(2), ijk_min(3) ) 
     437               CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max ) 
     438               CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min ) 
    439439            ELSE 
    440440               ijk_max = MAXLOC( ze3t(:,:,:) ) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/ICB/icbutl.F90

    r10297 r10314  
    7373      va_e(:,:) = 0._wp   ;   va_e(1:jpi,1:jpj) = vtau (:,:) * vmask(:,:,1) ! maybe mask useless because mask applied in sbcblk 
    7474      ! 
    75       CALL lbc_lnk_icb( uo_e, 'U', -1._wp, 1, 1 ) 
    76       CALL lbc_lnk_icb( vo_e, 'V', -1._wp, 1, 1 ) 
    77       CALL lbc_lnk_icb( ff_e, 'F', +1._wp, 1, 1 ) 
    78       CALL lbc_lnk_icb( ua_e, 'U', -1._wp, 1, 1 ) 
    79       CALL lbc_lnk_icb( va_e, 'V', -1._wp, 1, 1 ) 
    80       CALL lbc_lnk_icb( fr_e, 'T', +1._wp, 1, 1 ) 
    81       CALL lbc_lnk_icb( tt_e, 'T', +1._wp, 1, 1 ) 
     75      CALL lbc_lnk_icb( 'icbutl', uo_e, 'U', -1._wp, 1, 1 ) 
     76      CALL lbc_lnk_icb( 'icbutl', vo_e, 'V', -1._wp, 1, 1 ) 
     77      CALL lbc_lnk_icb( 'icbutl', ff_e, 'F', +1._wp, 1, 1 ) 
     78      CALL lbc_lnk_icb( 'icbutl', ua_e, 'U', -1._wp, 1, 1 ) 
     79      CALL lbc_lnk_icb( 'icbutl', va_e, 'V', -1._wp, 1, 1 ) 
     80      CALL lbc_lnk_icb( 'icbutl', fr_e, 'T', +1._wp, 1, 1 ) 
     81      CALL lbc_lnk_icb( 'icbutl', tt_e, 'T', +1._wp, 1, 1 ) 
    8282#if defined key_si3 
    8383      hicth(:,:) = 0._wp ;  hicth(1:jpi,1:jpj) = hm_i (:,:)   
    … …  
    8585      vi_e(:,:) = 0._wp ;   vi_e(1:jpi, 1:jpj) = v_ice(:,:) 
    8686      ! 
    87       CALL lbc_lnk_icb( hicth, 'T', +1._wp, 1, 1 ) 
    88       CALL lbc_lnk_icb( ui_e , 'U', -1._wp, 1, 1 ) 
    89       CALL lbc_lnk_icb( vi_e , 'V', -1._wp, 1, 1 ) 
     87      CALL lbc_lnk_icb( 'icbutl', hicth, 'T', +1._wp, 1, 1 ) 
     88      CALL lbc_lnk_icb( 'icbutl', ui_e , 'U', -1._wp, 1, 1 ) 
     89      CALL lbc_lnk_icb( 'icbutl', vi_e , 'V', -1._wp, 1, 1 ) 
    9090#endif 
    9191 
    … …  
    102102      ssh_e(0,jpj+1)     = ssh_e(1,jpj) 
    103103      ssh_e(jpi+1,jpj+1) = ssh_e(jpi,jpj) 
    104       CALL lbc_lnk_icb( ssh_e, 'T', +1._wp, 1, 1 ) 
     104      CALL lbc_lnk_icb( 'icbutl', ssh_e, 'T', +1._wp, 1, 1 ) 
    105105      ! 
    106106   END SUBROUTINE icb_utl_copy 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lbc_lnk_generic.h90

    r10068 r10314  
    4646 
    4747#if defined MULTI 
    48    SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn, kfld, cd_mpp, pval ) 
     48   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval ) 
    4949      INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    5050#else 
    51    SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn      , cd_mpp, pval ) 
     51   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , cd_mpp, pval ) 
    5252#endif 
     53      CHARACTER(len=*)            , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    5354      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied 
    5455      CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lbclnk.F90

    r10068 r10314  
    9090   ! 
    9191   INTERFACE lbc_bdy_lnk 
    92       MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
     92      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d, lbc_bdy_lnk_4d 
    9393   END INTERFACE 
    9494   ! 
    … …  
    179179   !!---------------------------------------------------------------------- 
    180180    
    181    SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 
    182       !!---------------------------------------------------------------------- 
     181   SUBROUTINE lbc_bdy_lnk_4d( cdname, pt4d, cd_type, psgn, ib_bdy ) 
     182      !!---------------------------------------------------------------------- 
     183      CHARACTER(len=*)          , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
     184      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pt4d      ! 3D array on which the lbc is applied 
     185      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     186      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold  
     187      INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
     188      !!---------------------------------------------------------------------- 
     189      CALL lbc_lnk_4d( cdname, pt4d, cd_type, psgn) 
     190   END SUBROUTINE lbc_bdy_lnk_4d 
     191 
     192   SUBROUTINE lbc_bdy_lnk_3d( cdname, pt3d, cd_type, psgn, ib_bdy ) 
     193      !!---------------------------------------------------------------------- 
     194      CHARACTER(len=*)          , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    183195      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
    184196      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    … …  
    186198      INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    187199      !!---------------------------------------------------------------------- 
    188       CALL lbc_lnk_3d( pt3d, cd_type, psgn) 
     200      CALL lbc_lnk_3d( cdname, pt3d, cd_type, psgn) 
    189201   END SUBROUTINE lbc_bdy_lnk_3d 
    190202 
    191203 
    192    SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 
    193       !!---------------------------------------------------------------------- 
     204   SUBROUTINE lbc_bdy_lnk_2d( cdname, pt2d, cd_type, psgn, ib_bdy ) 
     205      !!---------------------------------------------------------------------- 
     206      CHARACTER(len=*)        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    194207      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied 
    195208      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    … …  
    197210      INTEGER                 , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    198211      !!---------------------------------------------------------------------- 
    199       CALL lbc_lnk_2d( pt2d, cd_type, psgn) 
     212      CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn) 
    200213   END SUBROUTINE lbc_bdy_lnk_2d 
    201214 
    … …  
    203216!!gm  This routine should be removed with an optional halos size added in argument of generic routines 
    204217 
    205    SUBROUTINE lbc_lnk_2d_icb( pt2d, cd_type, psgn, ki, kj ) 
    206       !!---------------------------------------------------------------------- 
     218   SUBROUTINE lbc_lnk_2d_icb( cdname, pt2d, cd_type, psgn, ki, kj ) 
     219      !!---------------------------------------------------------------------- 
     220      CHARACTER(len=*)        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    207221      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
    208222      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    … …  
    210224      INTEGER                 , INTENT(in   ) ::   ki, kj    ! sizes of extra halo (not needed in non-mpp) 
    211225      !!---------------------------------------------------------------------- 
    212       CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 
     226      CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn ) 
    213227   END SUBROUTINE lbc_lnk_2d_icb 
    214228!!gm end 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lib_mpp.F90

    r10300 r10314  
    8484   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    8585   PUBLIC   mpp_ilor 
    86    PUBLIC   mpp_max_multiple 
    8786   PUBLIC   mppscatter, mppgather 
    8887   PUBLIC   mpp_ini_znl 
    … …  
    112111      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    113112   END INTERFACE 
    114    INTERFACE mpp_max_multiple 
    115       MODULE PROCEDURE mppmax_real_multiple 
    116    END INTERFACE 
    117113 
    118114   !! ========================= !! 
    … …  
    163159   INTEGER, PUBLIC                               ::   ncom_fsbc = 1                !: copy of sbc time step # nn_fsbc 
    164160   INTEGER, PUBLIC                               ::   ncom_dttrc = 1               !: copy of top time step # nn_dttrc 
     161   INTEGER, PUBLIC                               ::   ncom_freq                    !: frequency of comm diagnostic 
    165162   INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE ::   ncomm_sequence               !: size of communicated arrays (halos) 
     163   INTEGER, PARAMETER, PUBLIC                    ::   ncom_rec_max = 2000          !: max number of communication record 
    166164   INTEGER, PUBLIC                               ::   n_sequence_lbc = 0           !: # of communicated arraysvia lbc 
    167165   INTEGER, PUBLIC                               ::   n_sequence_glb = 0           !: # of global communications 
    … …  
    721719#  undef OPERATION_SUM_DD 
    722720 
    723    SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  ) 
    724       !!---------------------------------------------------------------------- 
    725       !!                  ***  routine mppmax_real  *** 
    726       !! 
    727       !! ** Purpose :   Maximum across processor of each element of a 1D arrays 
    728       !! 
    729       !!---------------------------------------------------------------------- 
    730       REAL(wp), DIMENSION(kdim), INTENT(inout) ::   pt1d   ! 1D arrays 
    731       INTEGER                  , INTENT(in   ) ::   kdim 
    732       INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! local communicator 
    733       !! 
    734       INTEGER  ::   ierror, ilocalcomm 
    735       REAL(wp), DIMENSION(kdim) ::  zwork 
    736       !!---------------------------------------------------------------------- 
    737       ilocalcomm = mpi_comm_oce 
    738       IF( PRESENT(kcom) )   ilocalcomm = kcom 
    739       ! 
    740       CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 
    741       pt1d(:) = zwork(:) 
    742       ! 
    743    END SUBROUTINE mppmax_real_multiple 
    744  
    745  
    746    SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) 
    747       !!------------------------------------------------------------------------ 
    748       !!             ***  routine mpp_minloc  *** 
    749       !! 
    750       !! ** Purpose :   Compute the global minimum of an array ptab 
    751       !!              and also give its global position 
    752       !! 
    753       !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC 
    754       !! 
    755       !!-------------------------------------------------------------------------- 
    756       REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array 
    757       REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask 
    758       REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab 
    759       INTEGER                      , INTENT(  out) ::   ki, kj  ! index of minimum in global frame 
    760       ! 
    761       INTEGER :: ierror 
    762       INTEGER , DIMENSION(2)   ::   ilocs 
    763       REAL(wp) ::   zmin   ! local minimum 
    764       REAL(wp), DIMENSION(2,1) ::   zain, zaout 
    765       !!----------------------------------------------------------------------- 
    766       ! 
    767       zmin  = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 
    768       ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    769       ! 
    770       ki = ilocs(1) + nimpp - 1 
    771       kj = ilocs(2) + njmpp - 1 
    772       ! 
    773       zain(1,:)=zmin 
    774       zain(2,:)=ki+10000.*kj 
    775       ! 
    776       CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OCE,ierror) 
    777       ! 
    778       pmin = zaout(1,1) 
    779       kj = INT(zaout(2,1)/10000.) 
    780       ki = INT(zaout(2,1) - 10000.*kj ) 
    781       ! 
    782    END SUBROUTINE mpp_minloc2d 
    783  
    784  
    785    SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk) 
    786       !!------------------------------------------------------------------------ 
    787       !!             ***  routine mpp_minloc  *** 
    788       !! 
    789       !! ** Purpose :   Compute the global minimum of an array ptab 
    790       !!              and also give its global position 
    791       !! 
    792       !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC 
    793       !! 
    794       !!-------------------------------------------------------------------------- 
    795       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
    796       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
    797       REAL(wp)                  , INTENT(  out) ::   pmin         ! Global minimum of ptab 
    798       INTEGER                   , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame 
    799       ! 
    800       INTEGER  ::   ierror 
    801       REAL(wp) ::   zmin     ! local minimum 
    802       INTEGER , DIMENSION(3)   ::   ilocs 
    803       REAL(wp), DIMENSION(2,1) ::   zain, zaout 
    804       !!----------------------------------------------------------------------- 
    805       ! 
    806       zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
    807       ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    808       ! 
    809       ki = ilocs(1) + nimpp - 1 
    810       kj = ilocs(2) + njmpp - 1 
    811       kk = ilocs(3) 
    812       ! 
    813       zain(1,:) = zmin 
    814       zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    815       ! 
    816       CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OCE,ierror) 
    817       ! 
    818       pmin = zaout(1,1) 
    819       kk   = INT( zaout(2,1) / 100000000. ) 
    820       kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000 
    821       ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. ) 
    822       ! 
    823    END SUBROUTINE mpp_minloc3d 
    824  
    825  
    826    SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj ) 
    827       !!------------------------------------------------------------------------ 
    828       !!             ***  routine mpp_maxloc  *** 
    829       !! 
    830       !! ** Purpose :   Compute the global maximum of an array ptab 
    831       !!              and also give its global position 
    832       !! 
    833       !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC 
    834       !! 
    835       !!-------------------------------------------------------------------------- 
    836       REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array 
    837       REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask 
    838       REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab 
    839       INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame 
    840       !! 
    841       INTEGER  :: ierror 
    842       INTEGER, DIMENSION (2)   ::   ilocs 
    843       REAL(wp) :: zmax   ! local maximum 
    844       REAL(wp), DIMENSION(2,1) ::   zain, zaout 
    845       !!----------------------------------------------------------------------- 
    846       ! 
    847       zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 
    848       ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 
    849       ! 
    850       ki = ilocs(1) + nimpp - 1 
    851       kj = ilocs(2) + njmpp - 1 
    852       ! 
    853       zain(1,:) = zmax 
    854       zain(2,:) = ki + 10000. * kj 
    855       ! 
    856       CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OCE,ierror) 
    857       ! 
    858       pmax = zaout(1,1) 
    859       kj   = INT( zaout(2,1) / 10000.     ) 
    860       ki   = INT( zaout(2,1) - 10000.* kj ) 
    861       ! 
    862    END SUBROUTINE mpp_maxloc2d 
    863  
    864  
    865    SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk ) 
    866       !!------------------------------------------------------------------------ 
    867       !!             ***  routine mpp_maxloc  *** 
    868       !! 
    869       !! ** Purpose :  Compute the global maximum of an array ptab 
    870       !!              and also give its global position 
    871       !! 
    872       !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC 
    873       !! 
    874       !!-------------------------------------------------------------------------- 
    875       REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array 
    876       REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   pmask        ! Local mask 
    877       REAL(wp)                   , INTENT(  out) ::   pmax         ! Global maximum of ptab 
    878       INTEGER                    , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
    879       ! 
    880       INTEGER  ::   ierror   ! local integer 
    881       REAL(wp) ::   zmax     ! local maximum 
    882       REAL(wp), DIMENSION(2,1) ::   zain, zaout 
    883       INTEGER , DIMENSION(3)   ::   ilocs 
    884       !!----------------------------------------------------------------------- 
    885       ! 
    886       zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 
    887       ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 
    888       ! 
    889       ki = ilocs(1) + nimpp - 1 
    890       kj = ilocs(2) + njmpp - 1 
    891       kk = ilocs(3) 
    892       ! 
    893       zain(1,:) = zmax 
    894       zain(2,:) = ki + 10000.*kj + 100000000.*kk 
    895       ! 
    896       CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OCE,ierror) 
    897       ! 
    898       pmax = zaout(1,1) 
    899       kk   = INT( zaout(2,1) / 100000000. ) 
    900       kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000 
    901       ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. ) 
    902       ! 
    903    END SUBROUTINE mpp_maxloc3d 
    904  
     721   !!---------------------------------------------------------------------- 
     722   !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 
     723   !!    
     724   !!---------------------------------------------------------------------- 
     725   !! 
     726#  define OPERATION_MINLOC 
     727#  define DIM_2d 
     728#     define ROUTINE_LOC           mpp_minloc2d 
     729#     include "mpp_loc_generic.h90" 
     730#     undef ROUTINE_LOC 
     731#  undef DIM_2d 
     732#  define DIM_3d 
     733#     define ROUTINE_LOC           mpp_minloc3d 
     734#     include "mpp_loc_generic.h90" 
     735#     undef ROUTINE_LOC 
     736#  undef DIM_3d 
     737#  undef OPERATION_MINLOC 
     738 
     739#  define OPERATION_MAXLOC 
     740#  define DIM_2d 
     741#     define ROUTINE_LOC           mpp_maxloc2d 
     742#     include "mpp_loc_generic.h90" 
     743#     undef ROUTINE_LOC 
     744#  undef DIM_2d 
     745#  define DIM_3d 
     746#     define ROUTINE_LOC           mpp_maxloc3d 
     747#     include "mpp_loc_generic.h90" 
     748#     undef ROUTINE_LOC 
     749#  undef DIM_3d 
     750#  undef OPERATION_MAXLOC 
    905751 
    906752   SUBROUTINE mppsync() 
    … …  
    12471093      ! 
    12481094      itaille = jpimax * ( ipj + 2*kextj ) 
     1095      ! 
     1096      IF( ln_timing ) CALL tic_tac(.TRUE.) 
    12491097      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
    12501098         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
    12511099         &                ncomm_north, ierr ) 
     1100      ! 
     1101      IF( ln_timing ) CALL tic_tac(.FALSE.) 
    12521102      ! 
    12531103      DO jr = 1, ndim_rank_north            ! recover the global north array 
    … …  
    12811131 
    12821132 
    1283    SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, kexti, kextj ) 
     1133   SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
    12841134      !!---------------------------------------------------------------------- 
    12851135      !!                  ***  routine mpp_lnk_2d_icb  *** 
    … …  
    13031153      !!                    nono   : number for local neighboring processors 
    13041154      !!---------------------------------------------------------------------- 
     1155      CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    13051156      REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    13061157      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    … …  
    13221173      iprecj = nn_hls + kextj 
    13231174 
     1175      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
    13241176 
    13251177      ! 1. standard boundary treatment 
    … …  
    13731225      !                           ! Migrations 
    13741226      imigr = ipreci * ( jpj + 2*kextj ) 
     1227      ! 
     1228      IF( ln_timing ) CALL tic_tac(.TRUE.) 
    13751229      ! 
    13761230      SELECT CASE ( nbondi ) 
    … …  
    13921246      END SELECT 
    13931247      ! 
     1248      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     1249      ! 
    13941250      !                           ! Write Dirichlet lateral conditions 
    13951251      iihom = jpi - nn_hls 
    … …  
    14261282      !                           ! Migrations 
    14271283      imigr = iprecj * ( jpi + 2*kexti ) 
     1284      ! 
     1285      IF( ln_timing ) CALL tic_tac(.TRUE.) 
    14281286      ! 
    14291287      SELECT CASE ( nbondj ) 
    … …  
    14451303      END SELECT 
    14461304      ! 
     1305      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     1306      ! 
    14471307      !                           ! Write Dirichlet lateral conditions 
    14481308      ijhom = jpj - nn_hls 
    … …  
    14661326   END SUBROUTINE mpp_lnk_2d_icb 
    14671327 
     1328 
     1329   SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb ) 
     1330      !!---------------------------------------------------------------------- 
     1331      !!                  ***  routine mpp_report  *** 
     1332      !! 
     1333      !! ** Purpose :   report use of mpp routines per time-setp 
     1334      !! 
     1335      !!---------------------------------------------------------------------- 
     1336      CHARACTER(len=*),           INTENT(in   ) ::   cdname      ! name of the calling subroutine 
     1337      INTEGER         , OPTIONAL, INTENT(in   ) ::   kpk, kpl, kpf 
     1338      LOGICAL         , OPTIONAL, INTENT(in   ) ::   ld_lbc, ld_glb 
     1339      !! 
     1340      LOGICAL ::   ll_lbc, ll_glb 
     1341      INTEGER ::    ji,  jj,  jk,  jh, jf   ! dummy loop indices 
     1342      !!---------------------------------------------------------------------- 
     1343      ! 
     1344      ll_lbc = .FALSE. 
     1345      IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc 
     1346      ll_glb = .FALSE. 
     1347      IF( PRESENT(ld_glb) ) ll_glb = ld_glb 
     1348      ! 
     1349      ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency 
     1350      ncom_freq = ncom_fsbc * ncom_dttrc 
     1351      IF( MOD( MAX(ncom_fsbc,ncom_dttrc), MIN(ncom_fsbc,ncom_dttrc) ) == 0 ) ncom_freq = MAX(ncom_fsbc,ncom_dttrc) 
     1352      ! 
     1353      IF ( ncom_stp == nit000+ncom_freq ) THEN   ! avoid to count extra communications in potential initializations at nit000 
     1354         IF( ll_lbc ) THEN 
     1355            IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) ) 
     1356            IF( .NOT. ALLOCATED(    crname_lbc) ) ALLOCATE(     crname_lbc(ncom_rec_max  ) ) 
     1357            n_sequence_lbc = n_sequence_lbc + 1 
     1358            IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lnk_generic, increase ncom_rec_max' )   ! deadlock 
     1359            crname_lbc(n_sequence_lbc) = cdname     ! keep the name of the calling routine 
     1360            ncomm_sequence(n_sequence_lbc,1) = kpk*kpl   ! size of 3rd and 4th dimensions 
     1361            ncomm_sequence(n_sequence_lbc,2) = kpf       ! number of arrays to be treated (multi) 
     1362         ENDIF 
     1363         IF( ll_glb ) THEN 
     1364            IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) ) 
     1365            n_sequence_glb = n_sequence_glb + 1 
     1366            IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lnk_generic, increase ncom_rec_max' )   ! deadlock 
     1367            crname_glb(n_sequence_glb) = cdname     ! keep the name of the calling routine 
     1368         ENDIF 
     1369      ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN 
     1370         CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
     1371         WRITE(numcom,*) ' ' 
     1372         WRITE(numcom,*) ' ------------------------------------------------------------' 
     1373         WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):' 
     1374         WRITE(numcom,*) ' ------------------------------------------------------------' 
     1375         WRITE(numcom,*) ' ' 
     1376         WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc 
     1377         jj = 0; jk = 0; jf = 0; jh = 0 
     1378         DO ji = 1, n_sequence_lbc 
     1379            IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1 
     1380            IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1 
     1381            IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1 
     1382            jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2)) 
     1383         END DO 
     1384         WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk 
     1385         WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf 
     1386         WRITE(numcom,'(A,I3)') '   from which 3D : ', jj 
     1387         WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj 
     1388         WRITE(numcom,*) ' ' 
     1389         WRITE(numcom,*) ' lbc_lnk called' 
     1390         jj = 1 
     1391         DO ji = 2, n_sequence_lbc 
     1392            IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 
     1393               WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 
     1394               jj = 0 
     1395            END IF 
     1396            jj = jj + 1  
     1397         END DO 
     1398         WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 
     1399         WRITE(numcom,*) ' ' 
     1400         IF ( n_sequence_glb > 0 ) THEN 
     1401            WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb 
     1402            jj = 1 
     1403            DO ji = 2, n_sequence_glb 
     1404               IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN 
     1405                  WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1)) 
     1406                  jj = 0 
     1407               END IF 
     1408               jj = jj + 1  
     1409            END DO 
     1410            WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb)) 
     1411            DEALLOCATE(crname_glb) 
     1412         ELSE 
     1413            WRITE(numcom,*) ' No MPI global communication ' 
     1414         ENDIF 
     1415         WRITE(numcom,*) ' ' 
     1416         WRITE(numcom,*) ' -----------------------------------------------' 
     1417         WRITE(numcom,*) ' ' 
     1418         DEALLOCATE(ncomm_sequence) 
     1419         DEALLOCATE(crname_lbc) 
     1420      ENDIF 
     1421   END SUBROUTINE mpp_report 
     1422 
    14681423    
    14691424   SUBROUTINE tic_tac (ld_tic, ld_global) 
    … …  
    14821437    END IF 
    14831438     
    1484 #if defined key_mpp_mpi 
    14851439    IF ( ld_tic ) THEN 
    14861440       tic_wt(ii) = MPI_Wtime()                                                    ! start count tic->tac (waiting time) 
    … …  
    14901444       tic_ct = MPI_Wtime()                                                        ! start count tac->tic (waiting time) 
    14911445    ENDIF 
    1492 #endif 
    14931446     
    14941447   END SUBROUTINE tic_tac 
    … …  
    15021455 
    15031456   INTERFACE mpp_sum 
    1504       MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd 
     1457      MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 
    15051458   END INTERFACE 
    15061459   INTERFACE mpp_max 
    … …  
    15161469      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    15171470   END INTERFACE 
    1518    INTERFACE mpp_max_multiple 
    1519       MODULE PROCEDURE mppmax_real_multiple 
    1520    END INTERFACE 
    15211471 
    15221472   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    … …  
    15451495   END SUBROUTINE mppsync 
    15461496 
    1547    SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine 
    1548       REAL   , DIMENSION(:) :: parr 
    1549       INTEGER               :: kdim 
    1550       INTEGER, OPTIONAL     :: kcom 
    1551       WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom 
    1552    END SUBROUTINE mpp_sum_as 
    1553  
    1554    SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine 
    1555       REAL   , DIMENSION(:,:) :: parr 
    1556       INTEGER               :: kdim 
    1557       INTEGER, OPTIONAL     :: kcom 
    1558       WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom 
    1559    END SUBROUTINE mpp_sum_a2s 
    1560  
    1561    SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine 
    1562       INTEGER, DIMENSION(:) :: karr 
    1563       INTEGER               :: kdim 
    1564       INTEGER, OPTIONAL     :: kcom 
    1565       WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom 
    1566    END SUBROUTINE mpp_sum_ai 
    1567  
    1568    SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine 
    1569       REAL                  :: psca 
    1570       INTEGER, OPTIONAL     :: kcom 
    1571       WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 
    1572    END SUBROUTINE mpp_sum_s 
    1573  
    1574    SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine 
    1575       integer               :: kint 
    1576       INTEGER, OPTIONAL     :: kcom 
    1577       WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 
    1578    END SUBROUTINE mpp_sum_i 
    1579  
    1580    SUBROUTINE mppsum_realdd( ytab, kcom ) 
    1581       COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar 
    1582       INTEGER , INTENT( in  ), OPTIONAL :: kcom 
    1583       WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab 
    1584    END SUBROUTINE mppsum_realdd 
    1585  
    1586    SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
    1587       INTEGER , INTENT( in )                        ::   kdim      ! size of ytab 
    1588       COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array 
    1589       INTEGER , INTENT( in  ), OPTIONAL :: kcom 
    1590       WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom 
    1591    END SUBROUTINE mppsum_a_realdd 
    1592  
    1593    SUBROUTINE mppmax_a_real( parr, kdim, kcom ) 
    1594       REAL   , DIMENSION(:) :: parr 
    1595       INTEGER               :: kdim 
    1596       INTEGER, OPTIONAL     :: kcom 
    1597       WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 
    1598    END SUBROUTINE mppmax_a_real 
    1599  
    1600    SUBROUTINE mppmax_real( psca, kcom ) 
    1601       REAL                  :: psca 
    1602       INTEGER, OPTIONAL     :: kcom 
    1603       WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom 
    1604    END SUBROUTINE mppmax_real 
    1605  
    1606    SUBROUTINE mppmin_a_real( parr, kdim, kcom ) 
    1607       REAL   , DIMENSION(:) :: parr 
    1608       INTEGER               :: kdim 
    1609       INTEGER, OPTIONAL     :: kcom 
    1610       WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 
    1611    END SUBROUTINE mppmin_a_real 
    1612  
    1613    SUBROUTINE mppmin_real( psca, kcom ) 
    1614       REAL                  :: psca 
    1615       INTEGER, OPTIONAL     :: kcom 
    1616       WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom 
    1617    END SUBROUTINE mppmin_real 
    1618  
    1619    SUBROUTINE mppmax_a_int( karr, kdim ,kcom) 
    1620       INTEGER, DIMENSION(:) :: karr 
    1621       INTEGER               :: kdim 
    1622       INTEGER, OPTIONAL     :: kcom 
    1623       WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 
    1624    END SUBROUTINE mppmax_a_int 
    1625  
    1626    SUBROUTINE mppmax_int( kint, kcom) 
    1627       INTEGER               :: kint 
    1628       INTEGER, OPTIONAL     :: kcom 
    1629       WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom 
    1630    END SUBROUTINE mppmax_int 
    1631  
    1632    SUBROUTINE mppmin_a_int( karr, kdim, kcom ) 
    1633       INTEGER, DIMENSION(:) :: karr 
    1634       INTEGER               :: kdim 
    1635       INTEGER, OPTIONAL     :: kcom 
    1636       WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 
    1637    END SUBROUTINE mppmin_a_int 
    1638  
    1639    SUBROUTINE mppmin_int( kint, kcom ) 
    1640       INTEGER               :: kint 
    1641       INTEGER, OPTIONAL     :: kcom 
    1642       WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 
    1643    END SUBROUTINE mppmin_int 
    1644  
    1645    SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj ) 
    1646       REAL                   :: pmin 
    1647       REAL , DIMENSION (:,:) :: ptab, pmask 
    1648       INTEGER :: ki, kj 
    1649       WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1) 
    1650    END SUBROUTINE mpp_minloc2d 
    1651  
    1652    SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk ) 
    1653       REAL                     :: pmin 
    1654       REAL , DIMENSION (:,:,:) :: ptab, pmask 
    1655       INTEGER :: ki, kj, kk 
    1656       WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1) 
    1657    END SUBROUTINE mpp_minloc3d 
    1658  
    1659    SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj ) 
    1660       REAL                   :: pmax 
    1661       REAL , DIMENSION (:,:) :: ptab, pmask 
    1662       INTEGER :: ki, kj 
    1663       WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1) 
    1664    END SUBROUTINE mpp_maxloc2d 
    1665  
    1666    SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk ) 
    1667       REAL                     :: pmax 
    1668       REAL , DIMENSION (:,:,:) :: ptab, pmask 
    1669       INTEGER :: ki, kj, kk 
    1670       WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1) 
    1671    END SUBROUTINE mpp_maxloc3d 
     1497   !!---------------------------------------------------------------------- 
     1498   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
     1499   !!    
     1500   !!---------------------------------------------------------------------- 
     1501   !! 
     1502#  define OPERATION_MAX 
     1503#  define INTEGER_TYPE 
     1504#  define DIM_0d 
     1505#     define ROUTINE_ALLREDUCE           mppmax_int 
     1506#     include "mpp_allreduce_generic.h90" 
     1507#     undef ROUTINE_ALLREDUCE 
     1508#  undef DIM_0d 
     1509#  define DIM_1d 
     1510#     define ROUTINE_ALLREDUCE           mppmax_a_int 
     1511#     include "mpp_allreduce_generic.h90" 
     1512#     undef ROUTINE_ALLREDUCE 
     1513#  undef DIM_1d 
     1514#  undef INTEGER_TYPE 
     1515! 
     1516#  define REAL_TYPE 
     1517#  define DIM_0d 
     1518#     define ROUTINE_ALLREDUCE           mppmax_real 
     1519#     include "mpp_allreduce_generic.h90" 
     1520#     undef ROUTINE_ALLREDUCE 
     1521#  undef DIM_0d 
     1522#  define DIM_1d 
     1523#     define ROUTINE_ALLREDUCE           mppmax_a_real 
     1524#     include "mpp_allreduce_generic.h90" 
     1525#     undef ROUTINE_ALLREDUCE 
     1526#  undef DIM_1d 
     1527#  undef REAL_TYPE 
     1528#  undef OPERATION_MAX 
     1529   !!---------------------------------------------------------------------- 
     1530   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
     1531   !!    
     1532   !!---------------------------------------------------------------------- 
     1533   !! 
     1534#  define OPERATION_MIN 
     1535#  define INTEGER_TYPE 
     1536#  define DIM_0d 
     1537#     define ROUTINE_ALLREDUCE           mppmin_int 
     1538#     include "mpp_allreduce_generic.h90" 
     1539#     undef ROUTINE_ALLREDUCE 
     1540#  undef DIM_0d 
     1541#  define DIM_1d 
     1542#     define ROUTINE_ALLREDUCE           mppmin_a_int 
     1543#     include "mpp_allreduce_generic.h90" 
     1544#     undef ROUTINE_ALLREDUCE 
     1545#  undef DIM_1d 
     1546#  undef INTEGER_TYPE 
     1547! 
     1548#  define REAL_TYPE 
     1549#  define DIM_0d 
     1550#     define ROUTINE_ALLREDUCE           mppmin_real 
     1551#     include "mpp_allreduce_generic.h90" 
     1552#     undef ROUTINE_ALLREDUCE 
     1553#  undef DIM_0d 
     1554#  define DIM_1d 
     1555#     define ROUTINE_ALLREDUCE           mppmin_a_real 
     1556#     include "mpp_allreduce_generic.h90" 
     1557#     undef ROUTINE_ALLREDUCE 
     1558#  undef DIM_1d 
     1559#  undef REAL_TYPE 
     1560#  undef OPERATION_MIN 
     1561 
     1562   !!---------------------------------------------------------------------- 
     1563   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
     1564   !!    
     1565   !!   Global sum of 1D array or a variable (integer, real or complex) 
     1566   !!---------------------------------------------------------------------- 
     1567   !! 
     1568#  define OPERATION_SUM 
     1569#  define INTEGER_TYPE 
     1570#  define DIM_0d 
     1571#     define ROUTINE_ALLREDUCE           mppsum_int 
     1572#     include "mpp_allreduce_generic.h90" 
     1573#     undef ROUTINE_ALLREDUCE 
     1574#  undef DIM_0d 
     1575#  define DIM_1d 
     1576#     define ROUTINE_ALLREDUCE           mppsum_a_int 
     1577#     include "mpp_allreduce_generic.h90" 
     1578#     undef ROUTINE_ALLREDUCE 
     1579#  undef DIM_1d 
     1580#  undef INTEGER_TYPE 
     1581! 
     1582#  define REAL_TYPE 
     1583#  define DIM_0d 
     1584#     define ROUTINE_ALLREDUCE           mppsum_real 
     1585#     include "mpp_allreduce_generic.h90" 
     1586#     undef ROUTINE_ALLREDUCE 
     1587#  undef DIM_0d 
     1588#  define DIM_1d 
     1589#     define ROUTINE_ALLREDUCE           mppsum_a_real 
     1590#     include "mpp_allreduce_generic.h90" 
     1591#     undef ROUTINE_ALLREDUCE 
     1592#  undef DIM_1d 
     1593#  undef REAL_TYPE 
     1594#  undef OPERATION_SUM 
     1595 
     1596#  define OPERATION_SUM_DD 
     1597#  define COMPLEX_TYPE 
     1598#  define DIM_0d 
     1599#     define ROUTINE_ALLREDUCE           mppsum_realdd 
     1600#     include "mpp_allreduce_generic.h90" 
     1601#     undef ROUTINE_ALLREDUCE 
     1602#  undef DIM_0d 
     1603#  define DIM_1d 
     1604#     define ROUTINE_ALLREDUCE           mppsum_a_realdd 
     1605#     include "mpp_allreduce_generic.h90" 
     1606#     undef ROUTINE_ALLREDUCE 
     1607#  undef DIM_1d 
     1608#  undef COMPLEX_TYPE 
     1609#  undef OPERATION_SUM_DD 
     1610 
     1611   !!---------------------------------------------------------------------- 
     1612   !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 
     1613   !!    
     1614   !!---------------------------------------------------------------------- 
     1615   !! 
     1616#  define OPERATION_MINLOC 
     1617#  define DIM_2d 
     1618#     define ROUTINE_LOC           mpp_minloc2d 
     1619#     include "mpp_loc_generic.h90" 
     1620#     undef ROUTINE_LOC 
     1621#  undef DIM_2d 
     1622#  define DIM_3d 
     1623#     define ROUTINE_LOC           mpp_minloc3d 
     1624#     include "mpp_loc_generic.h90" 
     1625#     undef ROUTINE_LOC 
     1626#  undef DIM_3d 
     1627#  undef OPERATION_MINLOC 
     1628 
     1629#  define OPERATION_MAXLOC 
     1630#  define DIM_2d 
     1631#     define ROUTINE_LOC           mpp_maxloc2d 
     1632#     include "mpp_loc_generic.h90" 
     1633#     undef ROUTINE_LOC 
     1634#  undef DIM_2d 
     1635#  define DIM_3d 
     1636#     define ROUTINE_LOC           mpp_maxloc3d 
     1637#     include "mpp_loc_generic.h90" 
     1638#     undef ROUTINE_LOC 
     1639#  undef DIM_3d 
     1640#  undef OPERATION_MAXLOC 
    16721641 
    16731642   SUBROUTINE mpp_ilor( ld_switch, ldlast, kcom ) 
    … …  
    16921661   END SUBROUTINE mpp_comm_free 
    16931662    
    1694    SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom  ) 
    1695       REAL, DIMENSION(:) ::   ptab   !  
    1696       INTEGER            ::   kdim   !  
    1697       INTEGER, OPTIONAL  ::   kcom   !  
    1698       WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim 
    1699    END SUBROUTINE mppmax_real_multiple 
    1700  
    17011663#endif 
    17021664 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_allreduce_generic.h90

    r10300 r10314  
    4242      INTEGER, OPTIONAL, INTENT(in   ) ::   kdim        ! optional pointer dimension 
    4343      INTEGER, OPTIONAL, INTENT(in   ) ::   kcom        ! optional communicator 
     44#if defined key_mpp_mpi 
    4445      ! 
    4546      INTEGER :: ipi, ii, ierr 
    4647      INTEGER :: ierror, ilocalcomm 
    4748      TMP_TYPE(:) 
     49      !!----------------------------------------------------------------------- 
     50      ! 
     51      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) 
    4852      ! 
    4953      ilocalcomm = mpi_comm_oce 
    … …  
    5559         ipi = I_SIZE(ptab)   ! 1st dimension 
    5660      ENDIF 
    57  
     61      ! 
     62      ALLOCATE(work(ipi)) 
    5863      IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) 
    59       ALLOCATE(work(ipi)) 
    6064      CALL mpi_allreduce( ARRAY_IN(:), work, ipi, MPI_TYPE, MPI_OPERATION, ilocalcomm, ierror ) 
     65      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    6166      DO ii = 1, ipi 
    6267         ARRAY_IN(ii) = work(ii) 
    6368      ENDDO 
    6469      DEALLOCATE(work) 
    65       IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    66       ! 
    67       IF( narea == 1 .AND. ncom_stp == nit000+5 ) THEN 
    68             IF( .NOT. ALLOCATED( crname_glb) ) THEN 
    69                ALLOCATE( crname_glb(2000), STAT=ierr ) 
    70                IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'allreduce_generic, cannot allocate crname' ) 
    71             ENDIF 
    72             n_sequence_glb = n_sequence_glb + 1 
    73             IF( n_sequence_glb > 2000 ) CALL ctl_stop( 'STOP', 'allreduce_generic, increase crname_glb first dimension' ) 
    74             crname_glb(n_sequence_glb)   = cdname    ! keep the name of the calling routine 
    75       ENDIF 
     70#else 
     71      WRITE(*,*) 'ROUTINE_ALLREDUCE: You should not have seen this print! error?' 
     72#endif 
    7673 
    7774   END SUBROUTINE ROUTINE_ALLREDUCE 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_bdy_generic.h90

    r10068 r10314  
    2121#   endif 
    2222 
    23    SUBROUTINE ROUTINE_BDY( ptab, cd_nat, psgn      , kb_bdy ) 
     23   SUBROUTINE ROUTINE_BDY( cdname, ptab, cd_nat, psgn      , kb_bdy ) 
    2424      !!---------------------------------------------------------------------- 
    2525      !!                  ***  routine mpp_lnk_bdy_3d  *** 
    … …  
    4242      !! 
    4343      !!---------------------------------------------------------------------- 
     44      CHARACTER(len=*)            , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    4445      ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied 
    4546      CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    … …  
    6162      ipl = L_SIZE(ptab)   ! 4th    - 
    6263      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
     64      ! 
     65      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 
    6366      !       
    6467      ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   & 
    … …  
    132135         imigr = nn_hls * jpj * ipk * ipl 
    133136         ! 
     137         IF( ln_timing ) CALL tic_tac(.TRUE.) 
     138         ! 
    134139         SELECT CASE ( nbondi_bdy(IBD_IN(jf)) ) 
    135140         CASE ( -1 ) 
    … …  
    150155         END SELECT 
    151156         ! 
     157         IF( ln_timing ) CALL tic_tac(.FALSE.) 
     158         ! 
    152159         !                           ! Write Dirichlet lateral conditions 
    153160         iihom = nlci-nn_hls 
    … …  
    205212         imigr = nn_hls * jpi * ipk * ipl 
    206213         ! 
     214         IF( ln_timing ) CALL tic_tac(.TRUE.) 
     215         !  
    207216         SELECT CASE ( nbondj_bdy(IBD_IN(jf)) ) 
    208217         CASE ( -1 ) 
    … …  
    222231            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    223232         END SELECT 
     233         ! 
     234         IF( ln_timing ) CALL tic_tac(.FALSE.) 
    224235         ! 
    225236         !                           ! Write Dirichlet lateral conditions 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_lnk_generic.h90

    r10297 r10314  
    6363      INTEGER  ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend 
    6464      INTEGER  ::   ierr 
    65       INTEGER  ::   icom_freq 
    6665      REAL(wp) ::   zland 
    6766      INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend 
    … …  
    7372      ipl = L_SIZE(ptab)   ! 4th    - 
    7473      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
     74      ! 
     75      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 
    7576      ! 
    7677      ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   & 
    … …  
    151152      ! 
    152153      !                           ! Migrations 
    153       imigr = nn_hls * jpj * ipk * ipl * ipf 
    154       ! 
    155       IF( narea == 1 ) THEN 
    156  
    157          ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency 
    158          icom_freq = ncom_fsbc * ncom_dttrc 
    159          IF( MOD( MAX(ncom_fsbc,ncom_dttrc), MIN(ncom_fsbc,ncom_dttrc) ) == 0 ) icom_freq = MAX(ncom_fsbc,ncom_dttrc) 
    160           
    161          IF ( ncom_stp == nit000+icom_freq ) THEN   ! avoid to count extra communications in potential initializations at nit000 
    162             IF( .NOT. ALLOCATED( ncomm_sequence) ) THEN 
    163                ALLOCATE( ncomm_sequence(2000,2), STAT=ierr ) 
    164                IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'lnk_generic, cannot allocate ncomm_sequence' ) 
    165                ALLOCATE( crname_lbc(2000), STAT=ierr ) 
    166                IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'lnk_generic, cannot allocate crname' ) 
    167             ENDIF 
    168             n_sequence_lbc = n_sequence_lbc + 1 
    169             IF( n_sequence_lbc > 2000 ) CALL ctl_stop( 'STOP', 'lnk_generic, increase ncomm_sequence first dimension' ) 
    170             ncomm_sequence(n_sequence_lbc,1) = ipk*ipl   ! size of 3rd and 4th dimensions 
    171             ncomm_sequence(n_sequence_lbc,2) = ipf       ! number of arrays to be treated (multi) 
    172             crname_lbc    (n_sequence_lbc)   = cdname    ! keep the name of the calling routine 
    173          ELSE IF ( ncom_stp == (nit000+2*icom_freq) ) THEN 
    174             IF ( numcom == -1 ) THEN 
    175                CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
    176                WRITE(numcom,*) ' ' 
    177                WRITE(numcom,*) ' ------------------------------------------------------------' 
    178                WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):' 
    179                WRITE(numcom,*) ' ------------------------------------------------------------' 
    180                WRITE(numcom,*) ' ' 
    181                WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc 
    182                jj = 0; jk = 0; jf = 0; jh = 0 
    183                DO ji = 1, n_sequence_lbc 
    184                   IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1 
    185                   IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1 
    186                   IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1 
    187                   jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2)) 
    188                END DO 
    189                WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk 
    190                WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf 
    191                WRITE(numcom,'(A,I3)') '   from which 3D : ', jj 
    192                WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj 
    193                WRITE(numcom,*) ' ' 
    194                WRITE(numcom,*) ' lbc_lnk called' 
    195                jj = 1 
    196                DO ji = 2, n_sequence_lbc 
    197                   IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 
    198                     WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 
    199                     jj = 0 
    200                   END IF 
    201                   jj = jj + 1  
    202                END DO 
    203                WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 
    204                WRITE(numcom,*) ' ' 
    205                IF ( n_sequence_glb > 0 ) THEN 
    206                   WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb 
    207                   jj = 1 
    208                   DO ji = 2, n_sequence_glb 
    209                      IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN 
    210                        WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1)) 
    211                        jj = 0 
    212                      END IF 
    213                      jj = jj + 1  
    214                   END DO 
    215                   WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb)) 
    216                   DEALLOCATE(crname_glb) 
    217                ELSE 
    218                   WRITE(numcom,*) ' No MPI global communication ' 
    219                ENDIF 
    220                WRITE(numcom,*) ' ' 
    221                WRITE(numcom,*) ' -----------------------------------------------' 
    222                WRITE(numcom,*) ' ' 
    223                DEALLOCATE(ncomm_sequence) 
    224                DEALLOCATE(crname_lbc) 
    225             ENDIF 
    226          ENDIF 
    227       ENDIF 
     154      imigr = nn_hls * jpj * ipk * ipl * ipf       
    228155      ! 
    229156      IF( ln_timing ) CALL tic_tac(.TRUE.) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/SBC/sbcapr.F90

    r10068 r10314  
    9494      ! 
    9595      IF( ln_ref_apr ) THEN                        !* Compute whole inner domain mean masked ocean surface 
    96          tarea = glob_sum( e1e2t(:,:) ) 
     96         tarea = glob_sum( 'sbcapr', e1e2t(:,:) ) 
    9797         IF(lwp) WRITE(numout,*) '         Variable ref. Patm computed over a ocean surface of ', tarea*1e-6, 'km2' 
    9898      ELSE 
    … …  
    141141         ! 
    142142         !                                                  !* update the reference atmospheric pressure (if necessary) 
    143          IF( ln_ref_apr )   rn_pref = glob_sum( sf_apr(1)%fnow(:,:,1) * e1e2t(:,:) ) / tarea 
     143         IF( ln_ref_apr )   rn_pref = glob_sum( 'sbcapr', sf_apr(1)%fnow(:,:,1) * e1e2t(:,:) ) / tarea 
    144144         ! 
    145145         !                                                  !* Patm related forcing at kt 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/SBC/sbcfwb.F90

    r10170 r10314  
    8686         IF( kn_fwb == 3 .AND. ln_isfcav    )   CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' ) 
    8787         ! 
    88          area = glob_sum( e1e2t(:,:) * tmask(:,:,1))           ! interior global domain surface 
     88         area = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask(:,:,1))           ! interior global domain surface 
    8989         ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes 
    9090         ! and in case of no melt, it can generate HSSW. 
    … …  
    102102         ! 
    103103         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN 
    104             z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
     104            z_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
    105105            zcoef = z_fwf * rcp 
    106106            emp(:,:) = emp(:,:) - z_fwf              * tmask(:,:,1) 
    … …  
    127127            a_fwb_b = a_fwb                           ! mean sea level taking into account the ice+snow 
    128128                                                      ! sum over the global domain 
    129             a_fwb   = glob_sum( e1e2t(:,:) * ( sshn(:,:) + snwice_mass(:,:) * r1_rau0 ) ) 
     129            a_fwb   = glob_sum( 'sbcfwb', e1e2t(:,:) * ( sshn(:,:) + snwice_mass(:,:) * r1_rau0 ) ) 
    130130            a_fwb   = a_fwb * 1.e+3 / ( area * rday * 365. )     ! convert in Kg/m3/s = mm/s 
    131131!!gm        !                                                      !!bug 365d year  
    … …  
    155155            ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:) 
    156156            ! 
    157             zsurf_neg = glob_sum( e1e2t(:,:)*ztmsk_neg(:,:) )  ! Area filled by <0 and >0 erp  
    158             zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 
     157            zsurf_neg = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_neg(:,:) )  ! Area filled by <0 and >0 erp  
     158            zsurf_pos = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_pos(:,:) ) 
    159159            !                                                  ! fwf global mean (excluding ocean to ice/snow exchanges)  
    160             z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
     160            z_fwf     = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
    161161            !             
    162162            IF( z_fwf < 0._wp ) THEN         ! spread out over >0 erp area to increase evaporation 
    … …  
    168168            ENDIF 
    169169            ! 
    170             zsum_fwf   = glob_sum( e1e2t(:,:) * z_fwf )         ! fwf global mean over <0 or >0 erp area 
     170            zsum_fwf   = glob_sum( 'sbcfwb', e1e2t(:,:) * z_fwf )         ! fwf global mean over <0 or >0 erp area 
    171171!!gm :  zsum_fwf   = z_fwf * area   ???  it is right?  I think so.... 
    172172            z_fwf_nsrf =  zsum_fwf / ( zsurf_tospread + rsmall ) 
    173173            !                                                  ! weight to respect erp field 2D structure  
    174             zsum_erp   = glob_sum( ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) ) 
     174            zsum_erp   = glob_sum( 'sbcfwb', ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) ) 
    175175            z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall ) 
    176176            !                                                  ! final correction term to apply 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/ZDF/zdfiwm.F90

    r10297 r10314  
    463463      ecri_iwm(:,:) = ecri_iwm(:,:) * ssmask(:,:) 
    464464 
    465       zbot = glob_sum( e1e2t(:,:) * ebot_iwm(:,:) ) 
    466       zpyc = glob_sum( e1e2t(:,:) * epyc_iwm(:,:) ) 
    467       zcri = glob_sum( e1e2t(:,:) * ecri_iwm(:,:) ) 
     465      zbot = glob_sum( 'zdfiwm', e1e2t(:,:) * ebot_iwm(:,:) ) 
     466      zpyc = glob_sum( 'zdfiwm', e1e2t(:,:) * epyc_iwm(:,:) ) 
     467      zcri = glob_sum( 'zdfiwm', e1e2t(:,:) * ecri_iwm(:,:) ) 
    468468      IF(lwp) THEN 
    469469         WRITE(numout,*) '      High-mode wave-breaking energy:             ', zbot * 1.e-12_wp, 'TW' 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/lib_fortran.F90

    r10297 r10314  
    3434 
    3535   INTERFACE glob_sum 
    36       MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, & 
    37          &             glob_sum_2d_a, glob_sum_3d_a 
     36      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d 
    3837   END INTERFACE 
    3938   INTERFACE glob_sum_full 
    … …  
    4140   END INTERFACE 
    4241   INTERFACE glob_min 
    43       MODULE PROCEDURE glob_min_2d, glob_min_3d,glob_min_2d_a, glob_min_3d_a  
     42      MODULE PROCEDURE glob_min_2d, glob_min_3d 
    4443   END INTERFACE 
    4544   INTERFACE glob_max 
    46       MODULE PROCEDURE glob_max_2d, glob_max_3d,glob_max_2d_a, glob_max_3d_a  
     45      MODULE PROCEDURE glob_max_2d, glob_max_3d 
    4746   END INTERFACE 
    4847 
    … …  
    6261CONTAINS 
    6362 
    64    ! --- SUM --- 
    65    FUNCTION glob_sum_1d( ptab, kdim ) 
    66       !!---------------------------------------------------------------------- 
    67       !!                  ***  FUNCTION  glob_sum_1d *** 
    68       !! 
    69       !! ** Purpose : perform a sum in calling DDPDD routine 
    70       !!---------------------------------------------------------------------- 
    71       INTEGER , INTENT(in) :: kdim 
    72       REAL(wp), INTENT(in), DIMENSION(kdim) ::   ptab 
    73       REAL(wp)                              ::   glob_sum_1d   ! global sum 
    74       !! 
    75       COMPLEX(wp)::   ctmp 
    76       REAL(wp)   ::   ztmp 
    77       INTEGER    ::   ji   ! dummy loop indices 
    78       !!----------------------------------------------------------------------- 
    79       ! 
    80       ztmp = 0.e0 
    81       ctmp = CMPLX( 0.e0, 0.e0, wp ) 
    82       DO ji = 1, kdim 
    83          ztmp =  ptab(ji) 
    84          CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
    85          END DO 
    86       IF( lk_mpp )   CALL mpp_sum( 'lib_fortran', ctmp )   ! sum over the global domain 
    87       glob_sum_1d = REAL(ctmp,wp) 
    88       ! 
    89    END FUNCTION glob_sum_1d 
    90  
    91    FUNCTION glob_sum_2d( ptab ) 
    92       !!---------------------------------------------------------------------- 
    93       !!                  ***  FUNCTION  glob_sum_2d *** 
    94       !! 
    95       !! ** Purpose : perform a sum in calling DDPDD routine 
    96       !!---------------------------------------------------------------------- 
    97       REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab 
    98       REAL(wp)                             ::   glob_sum_2d   ! global masked sum 
    99       !! 
    100       COMPLEX(wp)::   ctmp 
    101       REAL(wp)   ::   ztmp 
    102       INTEGER    ::   ji, jj   ! dummy loop indices 
    103       !!----------------------------------------------------------------------- 
    104       ! 
    105       ztmp = 0.e0 
    106       ctmp = CMPLX( 0.e0, 0.e0, wp ) 
    107       DO jj = 1, jpj 
    108          DO ji =1, jpi 
    109          ztmp =  ptab(ji,jj) * tmask_i(ji,jj) 
    110          CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
    111          END DO 
    112       END DO 
    113       IF( lk_mpp )   CALL mpp_sum( 'lib_fortran', ctmp )   ! sum over the global domain 
    114       glob_sum_2d = REAL(ctmp,wp) 
    115       ! 
    116    END FUNCTION glob_sum_2d 
    117  
    118  
    119    FUNCTION glob_sum_3d( ptab ) 
    120       !!---------------------------------------------------------------------- 
    121       !!                  ***  FUNCTION  glob_sum_3d *** 
    122       !! 
    123       !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine 
    124       !!---------------------------------------------------------------------- 
    125       REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab 
    126       REAL(wp)                               ::   glob_sum_3d   ! global masked sum 
    127       !! 
    128       COMPLEX(wp)::   ctmp 
    129       REAL(wp)   ::   ztmp 
    130       INTEGER    ::   ji, jj, jk   ! dummy loop indices 
    131       INTEGER    ::   ijpk ! local variables: size of ptab 
    132       !!----------------------------------------------------------------------- 
    133       ! 
    134       ijpk = SIZE(ptab,3) 
    135       ! 
    136       ztmp = 0.e0 
    137       ctmp = CMPLX( 0.e0, 0.e0, wp ) 
    138       DO jk = 1, ijpk 
    139          DO jj = 1, jpj 
    140             DO ji =1, jpi 
    141             ztmp =  ptab(ji,jj,jk) * tmask_i(ji,jj) 
    142             CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
    143             END DO 
    144          END DO 
    145       END DO 
    146       IF( lk_mpp )   CALL mpp_sum( 'lib_fortran', ctmp )   ! sum over the global domain 
    147       glob_sum_3d = REAL(ctmp,wp) 
    148       ! 
    149    END FUNCTION glob_sum_3d 
    150  
    151  
    152    FUNCTION glob_sum_2d_a( ptab1, ptab2 ) 
    153       !!---------------------------------------------------------------------- 
    154       !!                  ***  FUNCTION  glob_sum_2d_a *** 
    155       !! 
    156       !! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine 
    157       !!---------------------------------------------------------------------- 
    158       REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2 
    159       REAL(wp)                             ::   glob_sum_2d_a   ! global masked sum 
    160       !! 
    161       COMPLEX(wp)::   ctmp 
    162       REAL(wp)   ::   ztmp 
    163       INTEGER    ::   ji, jj   ! dummy loop indices 
    164       !!----------------------------------------------------------------------- 
    165       ! 
    166       ztmp = 0.e0 
    167       ctmp = CMPLX( 0.e0, 0.e0, wp ) 
    168       DO jj = 1, jpj 
    169          DO ji =1, jpi 
    170          ztmp =  ptab1(ji,jj) * tmask_i(ji,jj) 
    171          CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
    172          ztmp =  ptab2(ji,jj) * tmask_i(ji,jj) 
    173          CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
    174          END DO 
    175       END DO 
    176       IF( lk_mpp )   CALL mpp_sum( 'lib_fortran', ctmp )   ! sum over the global domain 
    177       glob_sum_2d_a = REAL(ctmp,wp) 
    178       ! 
    179    END FUNCTION glob_sum_2d_a 
    180  
    181  
    182    FUNCTION glob_sum_3d_a( ptab1, ptab2 ) 
    183       !!---------------------------------------------------------------------- 
    184       !!                  ***  FUNCTION  glob_sum_3d_a *** 
    185       !! 
    186       !! ** Purpose : perform a sum on two 3D array in calling DDPDD routine 
    187       !!---------------------------------------------------------------------- 
    188       REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2 
    189       REAL(wp)                               ::   glob_sum_3d_a   ! global masked sum 
    190       !! 
    191       COMPLEX(wp)::   ctmp 
    192       REAL(wp)   ::   ztmp 
    193       INTEGER    ::   ji, jj, jk   ! dummy loop indices 
    194       INTEGER    ::   ijpk ! local variables: size of ptab 
    195       !!----------------------------------------------------------------------- 
    196       ! 
    197       ijpk = SIZE(ptab1,3) 
    198       ! 
    199       ztmp = 0.e0 
    200       ctmp = CMPLX( 0.e0, 0.e0, wp ) 
    201       DO jk = 1, ijpk 
    202          DO jj = 1, jpj 
    203             DO ji = 1, jpi 
    204                ztmp =  ptab1(ji,jj,jk) * tmask_i(ji,jj) 
    205                CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
    206                ztmp =  ptab2(ji,jj,jk) * tmask_i(ji,jj) 
    207                CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
    208             END DO 
    209          END DO     
    210       END DO 
    211       IF( lk_mpp )   CALL mpp_sum( 'lib_fortran', ctmp )   ! sum over the global domain 
    212       glob_sum_3d_a = REAL(ctmp,wp) 
    213       ! 
    214    END FUNCTION glob_sum_3d_a    
    215  
    216    FUNCTION glob_sum_full_2d( ptab ) 
    217       !!---------------------------------------------------------------------- 
    218       !!                  ***  FUNCTION  glob_sum_full_2d *** 
    219       !! 
    220       !! ** Purpose : perform a sum in calling DDPDD routine 
    221       !!---------------------------------------------------------------------- 
    222       REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab 
    223       REAL(wp)                             ::   glob_sum_full_2d   ! global sum (nomask) 
    224       !! 
    225       COMPLEX(wp)::   ctmp 
    226       REAL(wp)   ::   ztmp 
    227       INTEGER    ::   ji, jj   ! dummy loop indices 
    228       !!----------------------------------------------------------------------- 
    229       ! 
    230       ztmp = 0.e0 
    231       ctmp = CMPLX( 0.e0, 0.e0, wp ) 
    232       DO jj = 1, jpj 
    233          DO ji =1, jpi 
    234          ztmp =  ptab(ji,jj) * tmask_h(ji,jj)  
    235          CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
    236          END DO 
    237       END DO 
    238       IF( lk_mpp )   CALL mpp_sum( 'lib_fortran', ctmp )   ! sum over the global domain 
    239       glob_sum_full_2d = REAL(ctmp,wp) 
    240       ! 
    241    END FUNCTION glob_sum_full_2d 
    242  
    243    FUNCTION glob_sum_full_3d( ptab ) 
    244       !!---------------------------------------------------------------------- 
    245       !!                  ***  FUNCTION  glob_sum_full_3d *** 
    246       !! 
    247       !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine 
    248       !!---------------------------------------------------------------------- 
    249       REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab 
    250       REAL(wp)                               ::   glob_sum_full_3d   ! global sum (nomask) 
    251       !! 
    252       COMPLEX(wp)::   ctmp 
    253       REAL(wp)   ::   ztmp 
    254       INTEGER    ::   ji, jj, jk   ! dummy loop indices 
    255       INTEGER    ::   ijpk ! local variables: size of ptab 
    256       !!----------------------------------------------------------------------- 
    257       ! 
    258       ijpk = SIZE(ptab,3) 
    259       ! 
    260       ztmp = 0.e0 
    261       ctmp = CMPLX( 0.e0, 0.e0, wp ) 
    262       DO jk = 1, ijpk 
    263          DO jj = 1, jpj 
    264             DO ji =1, jpi 
    265             ztmp =  ptab(ji,jj,jk) * tmask_h(ji,jj) 
    266             CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
    267             END DO 
    268          END DO 
    269       END DO 
    270       IF( lk_mpp )   CALL mpp_sum( 'lib_fortran', ctmp )   ! sum over the global domain 
    271       glob_sum_full_3d = REAL(ctmp,wp) 
    272       ! 
    273    END FUNCTION glob_sum_full_3d 
    274  
    275    ! --- MIN --- 
    276    FUNCTION glob_min_2d( ptab )  
    277       !!----------------------------------------------------------------------- 
    278       !!                  ***  FUNCTION  glob_min_2D  *** 
    279       !! 
    280       !! ** Purpose : perform a masked min on the inner global domain of a 2D array 
    281       !!----------------------------------------------------------------------- 
    282       REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array 
    283       REAL(wp)                             ::   glob_min_2d   ! global masked min 
    284       !!----------------------------------------------------------------------- 
    285       ! 
    286       glob_min_2d = MINVAL( ptab(:,:)*tmask_i(:,:) ) 
    287       IF( lk_mpp )   CALL mpp_min( 'lib_fortran', glob_min_2d ) 
    288       ! 
    289    END FUNCTION glob_min_2d 
    290   
    291    FUNCTION glob_min_3d( ptab )  
    292       !!----------------------------------------------------------------------- 
    293       !!                  ***  FUNCTION  glob_min_3D  *** 
    294       !! 
    295       !! ** Purpose : perform a masked min on the inner global domain of a 3D array 
    296       !!----------------------------------------------------------------------- 
    297       REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array 
    298       REAL(wp)                               ::   glob_min_3d   ! global masked min 
    299       !! 
    300       INTEGER :: jk 
    301       INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 
    302       !!----------------------------------------------------------------------- 
    303       ! 
    304       ijpk = SIZE(ptab,3) 
    305       ! 
    306       glob_min_3d = MINVAL( ptab(:,:,1)*tmask_i(:,:) ) 
    307       DO jk = 2, ijpk 
    308          glob_min_3d = MIN( glob_min_3d, MINVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) 
    309       END DO 
    310       IF( lk_mpp )   CALL mpp_min( 'lib_fortran', glob_min_3d ) 
    311       ! 
    312    END FUNCTION glob_min_3d 
    313  
    314  
    315    FUNCTION glob_min_2d_a( ptab1, ptab2 )  
    316       !!----------------------------------------------------------------------- 
    317       !!                  ***  FUNCTION  glob_min_2D _a *** 
    318       !! 
    319       !! ** Purpose : perform a masked min on the inner global domain of two 2D array 
    320       !!----------------------------------------------------------------------- 
    321       REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array 
    322       REAL(wp)            , DIMENSION(2)   ::   glob_min_2d_a   ! global masked min 
    323       !!----------------------------------------------------------------------- 
    324       !              
    325       glob_min_2d_a(1) = MINVAL( ptab1(:,:)*tmask_i(:,:) ) 
    326       glob_min_2d_a(2) = MINVAL( ptab2(:,:)*tmask_i(:,:) ) 
    327       IF( lk_mpp )   CALL mpp_min( 'lib_fortran', glob_min_2d_a, 2 ) 
    328       ! 
    329    END FUNCTION glob_min_2d_a 
    330   
    331   
    332    FUNCTION glob_min_3d_a( ptab1, ptab2 )  
    333       !!----------------------------------------------------------------------- 
    334       !!                  ***  FUNCTION  glob_min_3D_a *** 
    335       !! 
    336       !! ** Purpose : perform a masked min on the inner global domain of two 3D array 
    337       !!----------------------------------------------------------------------- 
    338       REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array 
    339       REAL(wp)            , DIMENSION(2)     ::   glob_min_3d_a   ! global masked min 
    340       !! 
    341       INTEGER :: jk 
    342       INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 
    343       !!----------------------------------------------------------------------- 
    344       ! 
    345       ijpk = SIZE(ptab1,3) 
    346       ! 
    347       glob_min_3d_a(1) = MINVAL( ptab1(:,:,1)*tmask_i(:,:) ) 
    348       glob_min_3d_a(2) = MINVAL( ptab2(:,:,1)*tmask_i(:,:) ) 
    349       DO jk = 2, ijpk 
    350          glob_min_3d_a(1) = MIN( glob_min_3d_a(1), MINVAL( ptab1(:,:,jk)*tmask_i(:,:) ) ) 
    351          glob_min_3d_a(2) = MIN( glob_min_3d_a(2), MINVAL( ptab2(:,:,jk)*tmask_i(:,:) ) ) 
    352       END DO 
    353       IF( lk_mpp )   CALL mpp_min( 'lib_fortran', glob_min_3d_a, 2 ) 
    354       ! 
    355    END FUNCTION glob_min_3d_a 
    356  
    357    ! --- MAX --- 
    358    FUNCTION glob_max_2d( ptab )  
    359       !!----------------------------------------------------------------------- 
    360       !!                  ***  FUNCTION  glob_max_2D  *** 
    361       !! 
    362       !! ** Purpose : perform a masked max on the inner global domain of a 2D array 
    363       !!----------------------------------------------------------------------- 
    364       REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array 
    365       REAL(wp)                             ::   glob_max_2d   ! global masked max 
    366       !!----------------------------------------------------------------------- 
    367       ! 
    368       glob_max_2d = MAXVAL( ptab(:,:)*tmask_i(:,:) ) 
    369       IF( lk_mpp )   CALL mpp_max( 'lib_fortran', glob_max_2d ) 
    370       ! 
    371    END FUNCTION glob_max_2d 
    372   
    373    FUNCTION glob_max_3d( ptab )  
    374       !!----------------------------------------------------------------------- 
    375       !!                  ***  FUNCTION  glob_max_3D  *** 
    376       !! 
    377       !! ** Purpose : perform a masked max on the inner global domain of a 3D array 
    378       !!----------------------------------------------------------------------- 
    379       REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array 
    380       REAL(wp)                               ::   glob_max_3d   ! global masked max 
    381       !! 
    382       INTEGER :: jk 
    383       INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 
    384       !!----------------------------------------------------------------------- 
    385       ! 
    386       ijpk = SIZE(ptab,3) 
    387       ! 
    388       glob_max_3d = MAXVAL( ptab(:,:,1)*tmask_i(:,:) ) 
    389       DO jk = 2, ijpk 
    390          glob_max_3d = MAX( glob_max_3d, MAXVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) 
    391       END DO 
    392       IF( lk_mpp )   CALL mpp_max( 'lib_fortran', glob_max_3d ) 
    393       ! 
    394    END FUNCTION glob_max_3d 
    395  
    396  
    397    FUNCTION glob_max_2d_a( ptab1, ptab2 )  
    398       !!----------------------------------------------------------------------- 
    399       !!                  ***  FUNCTION  glob_max_2D _a *** 
    400       !! 
    401       !! ** Purpose : perform a masked max on the inner global domain of two 2D array 
    402       !!----------------------------------------------------------------------- 
    403       REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array 
    404       REAL(wp)            , DIMENSION(2)   ::   glob_max_2d_a   ! global masked max 
    405       !!----------------------------------------------------------------------- 
    406       !              
    407       glob_max_2d_a(1) = MAXVAL( ptab1(:,:)*tmask_i(:,:) ) 
    408       glob_max_2d_a(2) = MAXVAL( ptab2(:,:)*tmask_i(:,:) ) 
    409       IF( lk_mpp )   CALL mpp_max( 'lib_fortran', glob_max_2d_a, 2 ) 
    410       ! 
    411    END FUNCTION glob_max_2d_a 
    412   
    413   
    414    FUNCTION glob_max_3d_a( ptab1, ptab2 )  
    415       !!----------------------------------------------------------------------- 
    416       !!                  ***  FUNCTION  glob_max_3D_a *** 
    417       !! 
    418       !! ** Purpose : perform a masked max on the inner global domain of two 3D array 
    419       !!----------------------------------------------------------------------- 
    420       REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array 
    421       REAL(wp)            , DIMENSION(2)     ::   glob_max_3d_a   ! global masked max 
    422       !! 
    423       INTEGER :: jk 
    424       INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 
    425       !!----------------------------------------------------------------------- 
    426       ! 
    427       ijpk = SIZE(ptab1,3) 
    428       ! 
    429       glob_max_3d_a(1) = MAXVAL( ptab1(:,:,1)*tmask_i(:,:) ) 
    430       glob_max_3d_a(2) = MAXVAL( ptab2(:,:,1)*tmask_i(:,:) ) 
    431       DO jk = 2, ijpk 
    432          glob_max_3d_a(1) = MAX( glob_max_3d_a(1), MAXVAL( ptab1(:,:,jk)*tmask_i(:,:) ) ) 
    433          glob_max_3d_a(2) = MAX( glob_max_3d_a(2), MAXVAL( ptab2(:,:,jk)*tmask_i(:,:) ) ) 
    434       END DO 
    435       IF( lk_mpp )   CALL mpp_max( 'lib_fortran', glob_max_3d_a, 2 ) 
    436       ! 
    437    END FUNCTION glob_max_3d_a 
     63#  define GLOBSUM_CODE 
     64 
     65#     define DIM_1d 
     66#     define FUNCTION_GLOBSUM           glob_sum_1d 
     67#     include "lib_fortran_generic.h90" 
     68#     undef FUNCTION_GLOBSUM 
     69#     undef DIM_1d 
     70 
     71#     define DIM_2d 
     72#     define OPERATION_GLOBSUM 
     73#     define FUNCTION_GLOBSUM           glob_sum_2d 
     74#     include "lib_fortran_generic.h90" 
     75#     undef FUNCTION_GLOBSUM 
     76#     undef OPERATION_GLOBSUM 
     77#     define OPERATION_FULL_GLOBSUM 
     78#     define FUNCTION_GLOBSUM           glob_sum_full_2d 
     79#     include "lib_fortran_generic.h90" 
     80#     undef FUNCTION_GLOBSUM 
     81#     undef OPERATION_FULL_GLOBSUM 
     82#     undef DIM_2d 
     83 
     84#     define DIM_3d 
     85#     define OPERATION_GLOBSUM 
     86#     define FUNCTION_GLOBSUM           glob_sum_3d 
     87#     include "lib_fortran_generic.h90" 
     88#     undef FUNCTION_GLOBSUM 
     89#     undef OPERATION_GLOBSUM 
     90#     define OPERATION_FULL_GLOBSUM 
     91#     define FUNCTION_GLOBSUM           glob_sum_full_3d 
     92#     include "lib_fortran_generic.h90" 
     93#     undef FUNCTION_GLOBSUM 
     94#     undef OPERATION_FULL_GLOBSUM 
     95#     undef DIM_3d 
     96 
     97#  undef GLOBSUM_CODE 
     98 
     99 
     100#  define GLOBMINMAX_CODE 
     101 
     102#     define DIM_2d 
     103#     define OPERATION_GLOBMIN 
     104#     define FUNCTION_GLOBMINMAX           glob_min_2d 
     105#     include "lib_fortran_generic.h90" 
     106#     undef FUNCTION_GLOBMINMAX 
     107#     undef OPERATION_GLOBMIN 
     108#     define OPERATION_GLOBMAX 
     109#     define FUNCTION_GLOBMINMAX           glob_max_2d 
     110#     include "lib_fortran_generic.h90" 
     111#     undef FUNCTION_GLOBMINMAX 
     112#     undef OPERATION_GLOBMAX 
     113#     undef DIM_2d 
     114 
     115#     define DIM_3d 
     116#     define OPERATION_GLOBMIN 
     117#     define FUNCTION_GLOBMINMAX           glob_min_3d 
     118#     include "lib_fortran_generic.h90" 
     119#     undef FUNCTION_GLOBMINMAX 
     120#     undef OPERATION_GLOBMIN 
     121#     define OPERATION_GLOBMAX 
     122#     define FUNCTION_GLOBMINMAX           glob_max_3d 
     123#     include "lib_fortran_generic.h90" 
     124#     undef FUNCTION_GLOBMINMAX 
     125#     undef OPERATION_GLOBMAX 
     126#     undef DIM_3d 
     127#  undef GLOBMINMAX_CODE 
    438128 
    439129 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/stpctl.F90

    r10068 r10314  
    6161      !! 
    6262      INTEGER  ::   ji, jj, jk             ! dummy loop indices 
    63       INTEGER  ::   iih, ijh               ! local integers 
    64       INTEGER  ::   iiu, iju, iku          !   -       - 
    65       INTEGER  ::   iis1, ijs1, iks1       !   -       - 
    66       INTEGER  ::   iis2, ijs2, iks2       !   -       - 
     63      INTEGER  ::   ih(2)                  ! local integers 
     64      INTEGER  ::   iu(3)                  !   -       - 
     65      INTEGER  ::   is1(3)                 !   -       - 
     66      INTEGER  ::   is2(3)                 !   -       - 
    6767      REAL(wp) ::   zzz                    ! local real  
    6868      INTEGER , DIMENSION(3) ::   ilocu, ilocs1, ilocs2 
    … …  
    112112      ! 
    113113      IF( lk_mpp ) THEN 
    114          CALL mpp_max_multiple( zmax(:), 5 )    ! max over the global domain 
     114         CALL mpp_max( "stpctl", zmax )    ! max over the global domain 
    115115         ! 
    116116         nstop = NINT( zmax(5) )                 ! nstop indicator sheared among all local domains 
    … …  
    129129         &  ISNAN( zmax(1) + zmax(2) + zmax(3) )  ) THEN   ! NaN encounter in the tests 
    130130         IF( lk_mpp ) THEN 
    131             CALL mpp_maxloc( ABS(sshn)        , ssmask(:,:)  , zzz, iih , ijh        ) 
    132             CALL mpp_maxloc( ABS(un)          , umask (:,:,:), zzz, iiu , iju , iku  ) 
    133             CALL mpp_minloc( tsn(:,:,:,jp_sal), tmask (:,:,:), zzz, iis1, ijs1, iks1 ) 
    134             CALL mpp_maxloc( tsn(:,:,:,jp_sal), tmask (:,:,:), zzz, iis2, ijs2, iks2 ) 
     131            CALL mpp_maxloc( 'stpctl', ABS(sshn)        , ssmask(:,:)  , zzz, ih  ) 
     132            CALL mpp_maxloc( 'stpctl', ABS(un)          , umask (:,:,:), zzz, iu  ) 
     133            CALL mpp_minloc( 'stpctl', tsn(:,:,:,jp_sal), tmask (:,:,:), zzz, is1 ) 
     134            CALL mpp_maxloc( 'stpctl', tsn(:,:,:,jp_sal), tmask (:,:,:), zzz, is2 ) 
    135135         ELSE 
    136136            iloch  = MINLOC( ABS( sshn(:,:)   )                               ) 
    … …  
    138138            ilocs1 = MINLOC( tsn(:,:,:,jp_sal) , mask = tmask(:,:,:) == 1._wp ) 
    139139            ilocs2 = MAXLOC( tsn(:,:,:,jp_sal) , mask = tmask(:,:,:) == 1._wp ) 
    140             iih  = iloch (1) + nimpp - 1   ;   ijh  = iloch (2) + njmpp - 1 
    141             iiu  = ilocu (1) + nimpp - 1   ;   iju  = ilocu (2) + njmpp - 1   ;   iku  = ilocu (3) 
    142             iis1 = ilocs1(1) + nimpp - 1   ;   ijs1 = ilocs1(2) + njmpp - 1   ;   iks1 = ilocs1(3) 
    143             iis2 = ilocs2(1) + nimpp - 1   ;   ijs2 = ilocs2(2) + njmpp - 1   ;   iks2 = ilocs2(3) 
     140            ih(1)  = iloch (1) + nimpp - 1   ;   ih(2)  = iloch (2) + njmpp - 1 
     141            iu(1)  = ilocu (1) + nimpp - 1   ;   iu(2)  = ilocu (2) + njmpp - 1   ;   iu(3)  = ilocu (3) 
     142            is1(1) = ilocs1(1) + nimpp - 1   ;   is1(2) = ilocs1(2) + njmpp - 1   ;   is1(3) = ilocs1(3) 
     143            is2(1) = ilocs2(1) + nimpp - 1   ;   is2(2) = ilocs2(2) + njmpp - 1   ;   is2(3) = ilocs2(3) 
    144144         ENDIF 
    145145         IF(lwp) THEN 
    … …  
    147147            WRITE(numout,*) ' stp_ctl: |ssh| > 10 m  or  |U| > 10 m/s  or  S <= 0  or  S >= 100  or  NaN encounter in the tests' 
    148148            WRITE(numout,*) ' ======= ' 
    149             WRITE(numout,9100) kt,   zmax(1), iih , ijh 
    150             WRITE(numout,9200) kt,   zmax(2), iiu , iju , iku 
    151             WRITE(numout,9300) kt, - zmax(3), iis1, ijs1, iks1 
    152             WRITE(numout,9400) kt,   zmax(4), iis2, ijs2, iks2 
     149            WRITE(numout,9100) kt,   zmax(1), ih(1) , ih(2) 
     150            WRITE(numout,9200) kt,   zmax(2), iu(1) , iu(2) , iu(3) 
     151            WRITE(numout,9300) kt, - zmax(3), is1(1), is1(2), is1(3) 
     152            WRITE(numout,9400) kt,   zmax(4), is2(1), is2(2), is2(3) 
    153153            WRITE(numout,*) 
    154154            WRITE(numout,*) '          output of last computed fields in output.abort.nc file' 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/SAS/stpctl.F90

    r10068 r10314  
    8888      zmax(3) = MAXVAL(     -tm_i (:,:)+273.15_wp , mask = ssmask(:,:) == 1._wp )   ! min ice temperature 
    8989      ! 
    90       IF( lk_mpp ) THEN 
    91          CALL mpp_max_multiple( zmax(:), 3 )    ! max over the global domain 
    92       ENDIF 
     90      IF( lk_mpp ) CALL mpp_max( "stpctl", zmax )    ! max over the global domain 
    9391      ! 
    9492      IF( MOD( kt, nwrite ) == 1 .AND. lwp ) THEN 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/C14/trcwri_c14.F90

    r10070 r10314  
    9696     
    9797      IF( iom_use("AtmC14") ) THEN 
    98          zarea = glob_sum( e1e2t(:,:) )           ! global ocean surface 
    99          ztemp = glob_sum( c14sbc(:,:) * e1e2t(:,:) ) 
     98         zarea = glob_sum( 'trcwri_c14', e1e2t(:,:) )           ! global ocean surface 
     99         ztemp = glob_sum( 'trcwri_c14', c14sbc(:,:) * e1e2t(:,:) ) 
    100100         ztemp = ( ztemp / zarea - 1._wp ) * 1000._wp 
    101101         CALL iom_put( "AtmC14" , ztemp )   ! Global atmospheric DeltaC14 [permil] 
    102102      ENDIF 
    103103      IF( iom_use("K_C14") ) THEN 
    104          ztemp = glob_sum ( exch_c14(:,:) * e1e2t(:,:) ) 
     104         ztemp = glob_sum ( 'trcwri_c14', exch_c14(:,:) * e1e2t(:,:) ) 
    105105         ztemp = rsiyea * ztemp / zarea 
    106106         CALL iom_put( "K_C14" , ztemp )   ! global mean exchange velocity for C14/C ratio [m/yr] 
    107107      ENDIF 
    108108      IF( iom_use("K_CO2") ) THEN 
    109          zarea = glob_sum( e1e2t(:,:) )           ! global ocean surface 
    110          ztemp = glob_sum ( exch_co2(:,:) * e1e2t(:,:) ) 
     109         zarea = glob_sum( 'trcwri_c14', e1e2t(:,:) )           ! global ocean surface 
     110         ztemp = glob_sum ( 'trcwri_c14', exch_co2(:,:) * e1e2t(:,:) ) 
    111111         ztemp = 360000._wp * ztemp / zarea       ! cm/h units: directly comparable with literature 
    112112         CALL iom_put( "K_CO2", ztemp )  !  global mean CO2 piston velocity [cm/hr] 
    113113      ENDIF 
    114114      IF( iom_use("C14Inv") ) THEN 
    115          ztemp = glob_sum( trn(:,:,:,jp_c14) * cvol(:,:,:) ) 
     115         ztemp = glob_sum( 'trcwri_c14', trn(:,:,:,jp_c14) * cvol(:,:,:) ) 
    116116         ztemp = atomc14 * xdicsur * ztemp 
    117117         CALL iom_put( "C14Inv", ztemp )  !  Radiocarbon ocean inventory [10^26 atoms] 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/PISCES/P2Z/p2zexp.F90

    r10170 r10314  
    230230      END DO 
    231231      CALL lbc_lnk( 'p2zexp', cmask , 'T', 1. )      ! lateral boundary conditions on cmask   (sign unchanged) 
    232       areacot = glob_sum( e1e2t(:,:) * cmask(:,:) ) 
     232      areacot = glob_sum( 'p2zexp', e1e2t(:,:) * cmask(:,:) ) 
    233233      ! 
    234234      IF( ln_rsttr ) THEN 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/PISCES/P4Z/p4zflx.F90

    r10068 r10314  
    172172      END DO 
    173173 
    174       t_oce_co2_flx     = glob_sum( oce_co2(:,:) )                    !  Total Flux of Carbon 
     174      t_oce_co2_flx     = glob_sum( 'p4zflx', oce_co2(:,:) )                    !  Total Flux of Carbon 
    175175      t_oce_co2_flx_cum = t_oce_co2_flx_cum + t_oce_co2_flx       !  Cumulative Total Flux of Carbon 
    176 !      t_atm_co2_flx     = glob_sum( satmco2(:,:) * e1e2t(:,:) )       ! Total atmospheric pCO2 
     176!      t_atm_co2_flx     = glob_sum( 'p4zflx', satmco2(:,:) * e1e2t(:,:) )       ! Total atmospheric pCO2 
    177177      t_atm_co2_flx     =  atcco2      ! Total atmospheric pCO2 
    178178  

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/PISCES/P4Z/p4zprod.F90

    r10069 r10314  
    360360    ! Total primary production per year 
    361361    IF( iom_use( "tintpp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc )  )  & 
    362          & tpp = glob_sum( ( zprorcan(:,:,:) + zprorcad(:,:,:) ) * cvol(:,:,:) ) 
     362         & tpp = glob_sum( 'p4zprod', ( zprorcan(:,:,:) + zprorcad(:,:,:) ) * cvol(:,:,:) ) 
    363363 
    364364    IF( lk_iomput ) THEN 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/PISCES/P4Z/p4zsbc.F90

    r10170 r10314  
    368368               ztimes_riv = 1._wp / REAL(ntimes_riv, wp)  
    369369               DO jm = 1, ntimes_riv 
    370                   rivinput(ifpr) = rivinput(ifpr) + glob_sum( zriver(:,:,jm) * tmask(:,:,1) * ztimes_riv )  
     370                  rivinput(ifpr) = rivinput(ifpr) + glob_sum( 'p4zsbc', zriver(:,:,jm) * tmask(:,:,1) * ztimes_riv )  
    371371               END DO 
    372372               DEALLOCATE( zriver) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/PISCES/P4Z/p4zsink.F90

    r10297 r10314  
    208208     ! Total carbon export per year 
    209209     IF( iom_use( "tcexp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc )  )  & 
    210         &   t_oce_co2_exp = glob_sum( ( sinking(:,:,ik100) + sinking2(:,:,ik100) ) * e1e2t(:,:) * tmask(:,:,1) ) 
     210        &   t_oce_co2_exp = glob_sum( 'p4zsink', ( sinking(:,:,ik100) + sinking2(:,:,ik100) ) * e1e2t(:,:) * tmask(:,:,1) ) 
    211211     ! 
    212212     IF( lk_iomput ) THEN 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/PISCES/P4Z/p4zsms.F90

    r10069 r10314  
    355355         !                                                ! --------------------------- ! 
    356356         ! set total alkalinity, phosphate, nitrate & silicate 
    357          zarea          = 1._wp / glob_sum( cvol(:,:,:) ) * 1e6               
    358  
    359          zalksumn = glob_sum( trn(:,:,:,jptal) * cvol(:,:,:)  ) * zarea 
    360          zpo4sumn = glob_sum( trn(:,:,:,jppo4) * cvol(:,:,:)  ) * zarea * po4r 
    361          zno3sumn = glob_sum( trn(:,:,:,jpno3) * cvol(:,:,:)  ) * zarea * rno3 
    362          zsilsumn = glob_sum( trn(:,:,:,jpsil) * cvol(:,:,:)  ) * zarea 
     357         zarea          = 1._wp / glob_sum( 'p4zsms', cvol(:,:,:) ) * 1e6               
     358 
     359         zalksumn = glob_sum( 'p4zsms', trn(:,:,:,jptal) * cvol(:,:,:)  ) * zarea 
     360         zpo4sumn = glob_sum( 'p4zsms', trn(:,:,:,jppo4) * cvol(:,:,:)  ) * zarea * po4r 
     361         zno3sumn = glob_sum( 'p4zsms', trn(:,:,:,jpno3) * cvol(:,:,:)  ) * zarea * rno3 
     362         zsilsumn = glob_sum( 'p4zsms', trn(:,:,:,jpsil) * cvol(:,:,:)  ) * zarea 
    363363  
    364364         IF(lwp) WRITE(numout,*) '       TALKN mean : ', zalksumn 
    … …  
    376376         ! 
    377377         IF( .NOT. ln_top_euler ) THEN 
    378             zalksumb = glob_sum( trb(:,:,:,jptal) * cvol(:,:,:)  ) * zarea 
    379             zpo4sumb = glob_sum( trb(:,:,:,jppo4) * cvol(:,:,:)  ) * zarea * po4r 
    380             zno3sumb = glob_sum( trb(:,:,:,jpno3) * cvol(:,:,:)  ) * zarea * rno3 
    381             zsilsumb = glob_sum( trb(:,:,:,jpsil) * cvol(:,:,:)  ) * zarea 
     378            zalksumb = glob_sum( 'p4zsms', trb(:,:,:,jptal) * cvol(:,:,:)  ) * zarea 
     379            zpo4sumb = glob_sum( 'p4zsms', trb(:,:,:,jppo4) * cvol(:,:,:)  ) * zarea * po4r 
     380            zno3sumb = glob_sum( 'p4zsms', trb(:,:,:,jpno3) * cvol(:,:,:)  ) * zarea * rno3 
     381            zsilsumb = glob_sum( 'p4zsms', trb(:,:,:,jpsil) * cvol(:,:,:)  ) * zarea 
    382382  
    383383            IF(lwp) WRITE(numout,*) ' ' 
    … …  
    442442        ENDIF 
    443443        ! 
    444         no3budget = glob_sum( zwork(:,:,:) * cvol(:,:,:)  )   
     444        no3budget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:)  )   
    445445        no3budget = no3budget / areatot 
    446446        CALL iom_put( "pno3tot", no3budget ) 
    … …  
    460460        ENDIF 
    461461        ! 
    462         po4budget = glob_sum( zwork(:,:,:) * cvol(:,:,:)  )   
     462        po4budget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:)  )   
    463463        po4budget = po4budget / areatot 
    464464        CALL iom_put( "ppo4tot", po4budget ) 
    … …  
    468468         zwork(:,:,:) =  trn(:,:,:,jpsil) + trn(:,:,:,jpgsi) + trn(:,:,:,jpdsi)  
    469469         ! 
    470          silbudget = glob_sum( zwork(:,:,:) * cvol(:,:,:)  )   
     470         silbudget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:)  )   
    471471         silbudget = silbudget / areatot 
    472472         CALL iom_put( "psiltot", silbudget ) 
    … …  
    476476         zwork(:,:,:) =  trn(:,:,:,jpno3) * rno3 + trn(:,:,:,jptal) + trn(:,:,:,jpcal) * 2.               
    477477         ! 
    478          alkbudget = glob_sum( zwork(:,:,:) * cvol(:,:,:)  )         ! 
     478         alkbudget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:)  )         ! 
    479479         alkbudget = alkbudget / areatot 
    480480         CALL iom_put( "palktot", alkbudget ) 
    … …  
    487487         IF( ln_ligand)  zwork(:,:,:) = zwork(:,:,:) + trn(:,:,:,jpfep)                 
    488488         ! 
    489          ferbudget = glob_sum( zwork(:,:,:) * cvol(:,:,:)  )   
     489         ferbudget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:)  )   
    490490         ferbudget = ferbudget / areatot 
    491491         CALL iom_put( "pfertot", ferbudget ) 
    … …  
    496496      ! -------------------------------------------------------------------------------- 
    497497      IF( iom_use( "tnfix" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
    498          znitrpottot  = glob_sum ( nitrpot(:,:,:) * nitrfix * cvol(:,:,:) ) 
     498         znitrpottot  = glob_sum ( 'p4zsms', nitrpot(:,:,:) * nitrfix * cvol(:,:,:) ) 
    499499         CALL iom_put( "tnfix"  , znitrpottot * xfact3 )  ! Global  nitrogen fixation molC/l  to molN/m3  
    500500      ENDIF 
    501501      ! 
    502502      IF( iom_use( "tdenit" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
    503          zrdenittot = glob_sum ( denitr(:,:,:) * rdenit * xnegtr(:,:,:) * cvol(:,:,:) ) 
    504          zsdenittot = glob_sum ( sdenit(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 
     503         zrdenittot = glob_sum ( 'p4zsms', denitr(:,:,:) * rdenit * xnegtr(:,:,:) * cvol(:,:,:) ) 
     504         zsdenittot = glob_sum ( 'p4zsms', sdenit(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 
    505505         CALL iom_put( "tdenit" , ( zrdenittot + zsdenittot ) * xfact3 )  ! Total denitrification molC/l to molN/m3  
    506506      ENDIF 
    507507      ! 
    508508      IF( ln_check_mass .AND. kt == nitend ) THEN   ! Compute the budget of NO3, ALK, Si, Fer 
    509          t_atm_co2_flx  = t_atm_co2_flx / glob_sum( e1e2t(:,:) ) 
     509         t_atm_co2_flx  = t_atm_co2_flx / glob_sum( 'p4zsms', e1e2t(:,:) ) 
    510510         t_oce_co2_flx  = t_oce_co2_flx         * xfact1 * (-1 ) 
    511511         tpp            = tpp           * 1000. * xfact1 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/PISCES/P4Z/p5zprod.F90

    r10070 r10314  
    459459    ! Total primary production per year 
    460460    IF( iom_use( "tintpp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc )  )  & 
    461       & tpp = glob_sum( ( zprorcan(:,:,:) + zprorcad(:,:,:) + zprorcap(:,:,:) ) * cvol(:,:,:) ) 
     461      & tpp = glob_sum( 'p5zprod', ( zprorcan(:,:,:) + zprorcad(:,:,:) + zprorcap(:,:,:) ) * cvol(:,:,:) ) 
    462462 
    463463    IF( lk_iomput ) THEN 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/TRP/trcrad.F90

    r10068 r10314  
    150150            ENDIF 
    151151            !                                                         ! sum over the global domain  
    152             ztrcorb = glob_sum( MIN( 0., ptrb(:,:,:,jn) ) * cvol(:,:,:) ) 
    153             ztrcorn = glob_sum( MIN( 0., ptrn(:,:,:,jn) ) * cvol(:,:,:) ) 
    154             ! 
    155             ztrmasb = glob_sum( MAX( 0., ptrb(:,:,:,jn) ) * cvol(:,:,:) ) 
    156             ztrmasn = glob_sum( MAX( 0., ptrn(:,:,:,jn) ) * cvol(:,:,:) ) 
     152            ztrcorb = glob_sum( 'trcrad', MIN( 0., ptrb(:,:,:,jn) ) * cvol(:,:,:) ) 
     153            ztrcorn = glob_sum( 'trcrad', MIN( 0., ptrn(:,:,:,jn) ) * cvol(:,:,:) ) 
     154            ! 
     155            ztrmasb = glob_sum( 'trcrad', MAX( 0., ptrb(:,:,:,jn) ) * cvol(:,:,:) ) 
     156            ztrmasn = glob_sum( 'trcrad', MAX( 0., ptrn(:,:,:,jn) ) * cvol(:,:,:) ) 
    157157            ! 
    158158            IF( ztrcorb /= 0 ) THEN 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/trcbdy.F90

    r10069 r10314  
    7171            END SELECT 
    7272            ! Boundary points should be updated 
    73             CALL lbc_bdy_lnk( tra(:,:,:,jn), 'T', 1., ib_bdy ) 
     73            CALL lbc_bdy_lnk( 'trcbdy', tra(:,:,:,jn), 'T', 1., ib_bdy ) 
    7474            ! 
    7575         END DO 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/trcini.F90

    r10297 r10314  
    119119      END DO 
    120120      !                          ! total volume of the ocean  
    121       areatot = glob_sum( cvol(:,:,:) ) 
     121      areatot = glob_sum( 'trcini', cvol(:,:,:) ) 
    122122      ! 
    123123      trai(:) = 0._wp            ! initial content of all tracers 
    124124      DO jn = 1, jptra 
    125          trai(jn) = trai(jn) + glob_sum( trn(:,:,:,jn) * cvol(:,:,:)   ) 
     125         trai(jn) = trai(jn) + glob_sum( 'trcini', trn(:,:,:,jn) * cvol(:,:,:)   ) 
    126126      END DO 
    127127 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/trcnam.F90

    r10297 r10314  
    2323   USE trdtrc_oce  ! 
    2424   USE iom         ! I/O manager 
     25#if defined key_mpp_mpi 
    2526   USE lib_mpp, ONLY: ncom_dttrc 
     27#endif 
    2628 
    2729   IMPLICIT NONE 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/trcrst.F90

    r10297 r10314  
    316316      ! 
    317317      DO jn = 1, jptra 
    318          ztraf = glob_sum( trn(:,:,:,jn) * zvol(:,:,:) ) 
     318         ztraf = glob_sum( 'trcrst', trn(:,:,:,jn) * zvol(:,:,:) ) 
    319319         zmin  = MINVAL( trn(:,:,:,jn), mask= ((tmask*SPREAD(tmask_i,DIM=3,NCOPIES=jpk).NE.0.)) ) 
    320320         zmax  = MAXVAL( trn(:,:,:,jn), mask= ((tmask*SPREAD(tmask_i,DIM=3,NCOPIES=jpk).NE.0.)) ) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/TOP/trcstp.F90

    r10068 r10314  
    7373            cvol(:,:,jk) = e1e2t(:,:) * e3t_n(:,:,jk) * tmask(:,:,jk) 
    7474         END DO 
    75          areatot         = glob_sum( cvol(:,:,:) ) 
     75         areatot         = glob_sum( 'trcstp', cvol(:,:,:) ) 
    7676      ENDIF 
    7777      ! 
    … …  
    107107      ztrai = 0._wp                                                   !  content of all tracers 
    108108      DO jn = 1, jptra 
    109          ztrai = ztrai + glob_sum( trn(:,:,:,jn) * cvol(:,:,:)   ) 
     109         ztrai = ztrai + glob_sum( 'trcstp', trn(:,:,:,jn) * cvol(:,:,:)   ) 
    110110      END DO 
    111111      IF( lwp ) WRITE(numstr,9300) kt,  ztrai / areatot 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/tests/BENCH/MY_SRC/zdfiwm.F90

    r10297 r10314  
    468468      ecri_iwm(:,:) = ecri_iwm(:,:) * ssmask(:,:) 
    469469 
    470       zbot = glob_sum( e1e2t(:,:) * ebot_iwm(:,:) ) 
    471       zpyc = glob_sum( e1e2t(:,:) * epyc_iwm(:,:) ) 
    472       zcri = glob_sum( e1e2t(:,:) * ecri_iwm(:,:) ) 
     470      zbot = glob_sum( 'zdfiwm', e1e2t(:,:) * ebot_iwm(:,:) ) 
     471      zpyc = glob_sum( 'zdfiwm', e1e2t(:,:) * epyc_iwm(:,:) ) 
     472      zcri = glob_sum( 'zdfiwm', e1e2t(:,:) * ecri_iwm(:,:) ) 
    473473      IF(lwp) THEN 
    474474         WRITE(numout,*) '      High-mode wave-breaking energy:             ', zbot * 1.e-12_wp, 'TW' 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/tests/CANAL/MY_SRC/domvvl.F90

    r10297 r10314  
    412412         IF( ( z_tmax >  rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN 
    413413            IF( lk_mpp ) THEN 
    414                CALL mpp_maxloc( ze3t, tmask, z_tmax, ijk_max(1), ijk_max(2), ijk_max(3) ) 
    415                CALL mpp_minloc( ze3t, tmask, z_tmin, ijk_min(1), ijk_min(2), ijk_min(3) ) 
     414               CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max(1), ijk_max(2), ijk_max(3) ) 
     415               CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min(1), ijk_min(2), ijk_min(3) ) 
    416416            ELSE 
    417417               ijk_max = MAXLOC( ze3t(:,:,:) ) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/tests/CANAL/MY_SRC/stpctl.F90

    r10074 r10314  
    120120         &  ISNAN( zmax(1) + zmax(2) + zmax(3) )  ) THEN   ! NaN encounter in the tests 
    121121         IF( lk_mpp ) THEN 
    122             CALL mpp_maxloc( ABS(sshn)        , ssmask(:,:)  , zzz, iih, ijh ) 
    123             CALL mpp_maxloc( ABS(un)          , umask (:,:,:), zzz, iiu, iju, iku ) 
    124 !           CALL mpp_minloc( tsn(:,:,:,jp_sal), tmask (:,:,:), zzz, iis, ijs, iks ) 
     122            CALL mpp_maxloc( 'stpctl', ABS(sshn)        , ssmask(:,:)  , zzz, iih, ijh ) 
     123            CALL mpp_maxloc( 'stpctl', ABS(un)          , umask (:,:,:), zzz, iiu, iju, iku ) 
     124!           CALL mpp_minloc( 'stpctl', tsn(:,:,:,jp_sal), tmask (:,:,:), zzz, iis, ijs, iks ) 
    125125         ELSE 
    126126            iloch = MINLOC( ABS( sshn(:,:)   )                               ) 

  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/tests/VORTEX/MY_SRC/domvvl.F90

    r10297 r10314  
    435435         IF( ( z_tmax >  rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN 
    436436            IF( lk_mpp ) THEN 
    437                CALL mpp_maxloc( ze3t, tmask, z_tmax, ijk_max(1), ijk_max(2), ijk_max(3) ) 
    438                CALL mpp_minloc( ze3t, tmask, z_tmin, ijk_min(1), ijk_min(2), ijk_min(3) ) 
     437               CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max(1), ijk_max(2), ijk_max(3) ) 
     438               CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min(1), ijk_min(2), ijk_min(3) ) 
    439439            ELSE 
    440440               ijk_max = MAXLOC( ze3t(:,:,:) ) 
Note: See TracChangeset for help on using the changeset viewer.