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 869 – NEMO

Changeset 869


Ignore:
Timestamp:
2008-03-26T10:21:54+01:00 (16 years ago)
Author:
rblod
Message:

Parallelisation of LIM3. This commit seems to ensure the reproducibility mono/mpp. See ticket #77.

Location:
trunk/NEMO
Files:
20 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMO/LIM_SRC_3/limdia.F90

    r834 r869  
    163163          DO jj = njeq, jpjm1 
    164164             DO ji = fs_2, fs_jpim1   ! vector opt. 
    165                 vinfor(11) = vinfor(11) + v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 !undef def ice volume 
     165                IF( tms(ji,jj) == 1 ) THEN 
     166                   vinfor(11) = vinfor(11) + v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 !undef def ice volume 
     167                ENDIF 
    166168             END DO 
    167169          END DO 
    … …  
    170172       vinfor(13) = 0.0 
    171173 
    172        vinfor(15) = vinfor(15) / vinfor(7) ! these have to be divided by total ice volume to have the 
    173        vinfor(29) = vinfor(29) / vinfor(7) ! right value 
     174       vinfor(15) = vinfor(15) / MAX(vinfor(7),epsi06) ! these have to be divided by total ice volume to have the 
     175       vinfor(29) = vinfor(29) / MAX(vinfor(7),epsi06) ! right value 
    174176       vinfor(31) = SQRT( vinfor(31) / MAX( vinfor(7) , epsi06 ) ) 
    175        vinfor(67) = vinfor(67) / vinfor(7) 
    176  
    177        vinfor(53) = vinfor(53) / vinfor(5) ! these have to be divided by total ice extent to have the 
    178        vinfor(55) = vinfor(55) / vinfor(5) ! right value  
    179        vinfor(57) = vinfor(57) / vinfor(5) !  
    180        vinfor(79) = vinfor(79) / vinfor(5) ! 
     177       vinfor(67) = vinfor(67) / MAX(vinfor(7),epsi06) 
     178 
     179       vinfor(53) = vinfor(53) / MAX(vinfor(5),epsi06) ! these have to be divided by total ice extent to have the 
     180       vinfor(55) = vinfor(55) / MAX(vinfor(5),epsi06) ! right value  
     181       vinfor(57) = vinfor(57) / MAX(vinfor(5),epsi06) !  
     182       vinfor(79) = vinfor(79) / MAX(vinfor(5),epsi06) ! 
    181183 
    182184       zindb      = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(3))) ! 
    … …  
    191193          DO jj = njeq, jpjm1 
    192194             DO ji = fs_2, fs_jpim1   ! vector opt. 
    193                 vinfor(33) = vinfor(33) + d_v_i_trp(ji,jj,jl)*aire(ji,jj) / 1.0e12 !ice volume 
    194                 vinfor(35) = vinfor(35) + d_v_i_thd(ji,jj,jl)*aire(ji,jj) / 1.0e12 !ice volume 
     195                IF( tms(ji,jj) == 1 ) THEN 
     196                   vinfor(33) = vinfor(33) + d_v_i_trp(ji,jj,jl)*aire(ji,jj) / 1.0e12 !ice volume 
     197                   vinfor(35) = vinfor(35) + d_v_i_thd(ji,jj,jl)*aire(ji,jj) / 1.0e12 !ice volume 
     198                ENDIF 
    195199             END DO 
    196200          END DO 
    … …  
    199203       DO jj = njeq, jpjm1 
    200204          DO ji = fs_2, fs_jpim1   ! vector opt. 
    201              vinfor(37) = vinfor(37) + diag_sni_gr(ji,jj)*aire(ji,jj) / 1.0e12 !th growth rates 
    202              vinfor(39) = vinfor(39) + diag_lat_gr(ji,jj)*aire(ji,jj) / 1.0e12  
    203              vinfor(41) = vinfor(41) + diag_bot_gr(ji,jj)*aire(ji,jj) / 1.0e12 
    204              vinfor(43) = vinfor(43) + diag_dyn_gr(ji,jj)*aire(ji,jj) / 1.0e12  
    205              vinfor(45) = vinfor(45) + dv_dt_thd(ji,jj,5)*aire(ji,jj) / 1.0e12 
    206              vinfor(47) = vinfor(47) + v_newice(ji,jj) *aire(ji,jj) / 1.0e12 / rdt_ice ! volume acc in OW 
     205                IF( tms(ji,jj) == 1 ) THEN 
     206                   vinfor(37) = vinfor(37) + diag_sni_gr(ji,jj)*aire(ji,jj) / 1.0e12 !th growth rates 
     207                   vinfor(39) = vinfor(39) + diag_lat_gr(ji,jj)*aire(ji,jj) / 1.0e12  
     208                   vinfor(41) = vinfor(41) + diag_bot_gr(ji,jj)*aire(ji,jj) / 1.0e12 
     209                   vinfor(43) = vinfor(43) + diag_dyn_gr(ji,jj)*aire(ji,jj) / 1.0e12  
     210                   vinfor(45) = vinfor(45) + dv_dt_thd(ji,jj,5)*aire(ji,jj) / 1.0e12 
     211                   vinfor(47) = vinfor(47) + v_newice(ji,jj) *aire(ji,jj) / 1.0e12 / rdt_ice ! volume acc in OW 
     212                ENDIF 
    207213          END DO 
    208214       END DO 
    … …  
    217223          END DO 
    218224       END DO 
    219        vinfor(63) = vinfor(63) / vinfor(3) ! these have to be divided by total ice area 
     225       vinfor(63) = vinfor(63) / MAX(vinfor(3),epsi06) ! these have to be divided by total ice area 
    220226 
    221227       !! 1.2) Diagnostics dependent on age 
    … …  
    348354       DO jj = 2, njeqm1 
    349355          DO ji = fs_2, fs_jpim1   ! vector opt. 
    350              vinfor(38) = vinfor(38) + diag_sni_gr(ji,jj)*aire(ji,jj) / 1.0e12 !th growth rates 
    351              vinfor(40) = vinfor(40) + diag_lat_gr(ji,jj)*aire(ji,jj) / 1.0e12  
    352              vinfor(42) = vinfor(42) + diag_bot_gr(ji,jj)*aire(ji,jj) / 1.0e12 
    353              vinfor(44) = vinfor(44) + diag_dyn_gr(ji,jj)*aire(ji,jj) / 1.0e12  
    354              vinfor(46) = vinfor(46) + dv_dt_thd(ji,jj,5)*aire(ji,jj) / 1.0e12 
    355              vinfor(48) = vinfor(48) + v_newice(ji,jj) *aire(ji,jj) / 1.0e12 / rdt_ice ! volume acc in OW 
     356                IF( tms(ji,jj) == 1 ) THEN 
     357                   vinfor(38) = vinfor(38) + diag_sni_gr(ji,jj)*aire(ji,jj) / 1.0e12 !th growth rates 
     358                   vinfor(40) = vinfor(40) + diag_lat_gr(ji,jj)*aire(ji,jj) / 1.0e12  
     359                   vinfor(42) = vinfor(42) + diag_bot_gr(ji,jj)*aire(ji,jj) / 1.0e12 
     360                   vinfor(44) = vinfor(44) + diag_dyn_gr(ji,jj)*aire(ji,jj) / 1.0e12  
     361                   vinfor(46) = vinfor(46) + dv_dt_thd(ji,jj,5)*aire(ji,jj) / 1.0e12 
     362                   vinfor(48) = vinfor(48) + v_newice(ji,jj) *aire(ji,jj) / 1.0e12 / rdt_ice ! volume acc in OW 
     363                ENDIF 
    356364          END DO 
    357365       END DO 

  • trunk/NEMO/LIM_SRC_3/limdyn.F90

    r868 r869  
    103103         ! --------------------------------------------------- 
    104104 
    105          IF( lk_mpp ) THEN                    ! mpp: compute over the whole domain 
     105         IF( lk_mpp .OR. nbit_cmp == 1 ) THEN                    ! mpp: compute over the whole domain 
    106106            i_j1 = 1 
    107107            i_jpj = jpj 
    … …  
    160160            ENDIF 
    161161 
    162          ENDIF 
    163  
    164          u_ice(:,1) = 0.0       !ibug  est-ce vraiment necessaire? 
    165          v_ice(:,1) = 0.0 
    166  
    167          IF(ln_ctl) THEN  
    168             CALL prt_ctl(tab2d_1=u_oce , clinfo1=' lim_dyn  : u_oce :', tab2d_2=v_oce , clinfo2=' v_oce :') 
    169             CALL prt_ctl(tab2d_1=u_ice , clinfo1=' lim_dyn  : u_ice :', tab2d_2=v_ice , clinfo2=' v_ice :') 
    170162         ENDIF 
    171163 

  • trunk/NEMO/LIM_SRC_3/limistate.F90

    r834 r869  
    523523         DO jk = 1, nlay_s 
    524524            CALL lbc_lnk(t_s(:,:,jk,jl), 'T', 1. ) 
     525            CALL lbc_lnk(e_s(:,:,jk,jl), 'T', 1. ) 
    525526         END DO 
    526527         DO jk = 1, nlay_i 

  • trunk/NEMO/LIM_SRC_3/limitd_me.F90

    r868 r869  
    3030   USE limcons 
    3131   USE prtctl           ! Print control 
     32   USE lib_mpp 
    3233  
    3334   IMPLICIT NONE 
    … …  
    187188 
    188189        LOGICAL   ::           & 
    189            iterate_ridging,    &  ! if true, repeat the ridging 
    190190           asum_error              ! flag for asum .ne. 1 
     191 
     192        INTEGER :: iterate_ridging ! if true, repeat the ridging 
    191193 
    192194        REAL(wp) ::  &          
    … …  
    282284!-----------------------------------------------------------------------------! 
    283285      niter = 1                 ! iteration counter 
    284       iterate_ridging = .true. 
    285  
    286  
    287       DO WHILE ( iterate_ridging .AND. niter < nitermax ) 
     286      iterate_ridging = 1 
     287 
     288 
     289      DO WHILE ( iterate_ridging > 0 .AND. niter < nitermax ) 
    288290 
    289291      DO jj = 1, jpj 
    … …  
    349351! rates were reduced above), ridge again with new rates. 
    350352 
    351       iterate_ridging = .false. 
     353      iterate_ridging = 0 
    352354 
    353355      DO jj = 1, jpj 
    … …  
    357359               opning(ji,jj)      = 0.0 
    358360            ELSE 
    359                iterate_ridging    = .true. 
     361               iterate_ridging    = 1 
    360362               divu_adv(ji,jj)    = (1.0 - asum(ji,jj)) / rdt_ice 
    361363               closing_net(ji,jj) = MAX(0.0, -divu_adv(ji,jj)) 
    … …  
    365367      END DO 
    366368 
     369      IF( lk_mpp ) CALL mpp_max(iterate_ridging) 
     370 
    367371! Repeat if necessary. 
    368372! NOTE: If strength smoothing is turned on, the ridging must be 
    … …  
    372376      niter = niter + 1 
    373377 
    374       IF (iterate_ridging) THEN 
     378      IF (iterate_ridging == 1) THEN 
    375379         IF (niter .GT. nitermax) THEN 
    376380            WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 
    … …  
    708712         CALL lbc_lnk( strength, 'T', 1. ) 
    709713 
    710          DO jj = 1, jpj - 1 
    711             DO ji = 1, jpi - 1 
     714         DO jj = 2, jpj - 1 
     715            DO ji = 2, jpi - 1 
    712716               IF ( ( asum(ji,jj) - ato_i(ji,jj) ) .GT. epsi11) THEN ! ice is 
    713717                                                                     ! present 
    … …  
    727731         END DO 
    728732 
    729          DO jj = 1, jpj - 1 
    730             DO ji = 1, jpi - 1 
     733         DO jj = 2, jpj - 1 
     734            DO ji = 2, jpi - 1 
    731735               strength(ji,jj) = zworka(ji,jj) 
    732736            END DO 
    733737         END DO 
     738         CALL lbc_lnk( strength, 'T', 1. ) 
    734739 
    735740      ENDIF ! ksmooth 
    … …  
    17601765      ! Abort model in case of negative area. 
    17611766      !----------------------------------------------------------------- 
    1762          IF( MAXVAL(a_i(:,:,jl)) .LT. -epsi11 ) THEN 
     1767         IF( MINVAL(a_i(:,:,jl)) .LT. -epsi11 ) THEN 
    17631768            DO jj = 1, jpj 
    17641769               DO ji = 1, jpi 

  • trunk/NEMO/LIM_SRC_3/limitd_th.F90

    r868 r869  
    2727   USE limcons 
    2828   USE prtctl           ! Print control 
     29   USE lib_mpp  
    2930  
    3031   IMPLICIT NONE 
    … …  
    10621063         jl                 ! category index 
    10631064 
    1064       LOGICAL ::   &  !: 
     1065      INTEGER ::   &  !: 
    10651066         zshiftflag          ! = .true. if ice must be shifted 
    10661067 
    … …  
    11491150      ! identify thicknesses that are too big 
    11501151      !--------------------------------------- 
    1151          zshiftflag = .false. 
     1152         zshiftflag = 0 
    11521153 
    11531154         DO jj = 1, jpj  
    11541155            DO ji = 1, jpi  
    11551156               IF (a_i(ji,jj,jl) .GT. zeps .AND. ht_i(ji,jj,jl) .GT. hi_max(jl) ) THEN  
    1156                   zshiftflag        = .true. 
     1157                  zshiftflag        = 1 
    11571158                  zdonor(ji,jj,jl)  = jl  
    11581159                  zdaice(ji,jj,jl)  = a_i(ji,jj,jl) 
    … …  
    11611162            END DO                 ! ji 
    11621163         END DO                 ! jj 
    1163  
    1164          IF (zshiftflag) THEN 
     1164         IF( lk_mpp ) CALL mpp_max(zshiftflag) 
     1165 
     1166         IF ( zshiftflag == 1 ) THEN 
    11651167 
    11661168      !------------------------------ 
    … …  
    11931195      ! Identify thicknesses that are too small 
    11941196      !----------------------------------------- 
    1195          zshiftflag = .false. 
     1197         zshiftflag = 0 
    11961198 
    11971199         DO jj = 1, jpj 
    … …  
    12001202                  ht_i(ji,jj,jl+1) .LE. hi_max(jl)) THEN 
    12011203 
    1202                   zshiftflag = .true. 
     1204                  zshiftflag = 1 
    12031205                  zdonor(ji,jj,jl) = jl + 1 
    12041206                  zdaice(ji,jj,jl) = a_i(ji,jj,jl+1)  
    … …  
    12081210         END DO                 ! jj 
    12091211 
    1210          IF (zshiftflag) THEN 
     1212         IF(lk_mpp) CALL mpp_max(zshiftflag) 
     1213         IF (zshiftflag==1) THEN 
    12111214 
    12121215      !------------------------------ 

  • trunk/NEMO/LIM_SRC_3/limmsh.F90

    r834 r869  
    216216      tms(:,:) = tmask(:,:,1)      ! ice T-point  : use surface tmask 
    217217 
    218       tmu(:,1) = 0.e0 
    219       tmu(1,:) = 0.e0 
    220       tmv(:,1) = 0.e0 
    221       tmv(1,:) = 0.e0 
     218!      tmu(:,1) = 0.e0 
     219!      tmu(1,:) = 0.e0 
     220!      tmv(:,1) = 0.e0 
     221!      tmv(1,:) = 0.e0 
    222222 
    223223      DO jj = 1, jpj - 1 
    224          DO ji = 2 , jpi - 1 
     224         DO ji = 1 , jpi - 1 
    225225            tmu(ji,jj) =  tms(ji,jj) * tms(ji+1,jj) 
    226226            tmv(ji,jj) =  tms(ji,jj) * tms(ji,jj+1) 
    … …  
    233233      CALL lbc_lnk( tmu(:,:), 'U', 1. ) 
    234234      CALL lbc_lnk( tmv(:,:), 'V', 1. ) 
     235      CALL lbc_lnk( tmf(:,:), 'F', 1. ) 
    235236       
    236237      ! unmasked and masked area of T-grid cell 

  • trunk/NEMO/LIM_SRC_3/limrhg.F90

    r868 r869  
    314314 
    315315      !-Initialise stress tensor  
    316       zs1(:,:)  = stress1_i(:,:) 
     316      zs1(:,:)  = stress1_i(:,:)  
    317317      zs2(:,:)  = stress2_i(:,:) 
    318318      zs12(:,:) = stress12_i(:,:) 
    … …  
    387387              END DO 
    388388           END DO 
     389           CALL lbc_lnk( v_ice1(:,:), 'U', -1. ) 
     390           CALL lbc_lnk( u_ice2(:,:), 'V', -1. ) 
    389391 
    390392!CDIR NOVERRCHK 
    … …  
    454456                    &        - dtotel*( (1.0-alphaevp)*ecc2*zs12(ji,jj) - zds(ji,jj) / & 
    455457                    &          ( 2.0*deltac(ji,jj) ) * zpreshc(ji,jj))) & 
    456                     &         / ( 1.0 + alphaevp*ecc2*dtotel ) 
     458                    &         / ( 1.0 + alphaevp*ecc2*dtotel )  
    457459 
    458460              END DO ! ji 
    … …  
    625627      END DO 
    626628 
     629      CALL lbc_lnk( u_ice(:,:), 'U', -1. )  
     630      CALL lbc_lnk( v_ice(:,:), 'V', -1. )  
     631 
    627632      DO jj = k_j1+1, k_jpj-1  
    628633         DO ji = fs_2, fs_jpim1 
    … …  
    641646      END DO 
    642647 
    643       CALL lbc_lnk( u_ice2(:,:), 'U', -1. )  
    644       CALL lbc_lnk( v_ice1(:,:), 'V', -1. ) 
     648      CALL lbc_lnk( u_ice2(:,:), 'V', -1. )  
     649      CALL lbc_lnk( v_ice1(:,:), 'U', -1. ) 
    645650 
    646651      ! Recompute delta, shear and div, inputs for mechanical redistribution  

  • trunk/NEMO/LIM_SRC_3/limrst_dimg.h90

    r825 r869  
    223223!     READ(inum,REC=irec)  sist(:,:) 
    224224!     irec = irec +1 
     225!RB bug 
    225226      READ(inum,REC=irec)  t_su(:,:) 
    226227      irec = irec +1 

  • trunk/NEMO/LIM_SRC_3/limthd.F90

    r867 r869  
    3030   USE limvar 
    3131   USE prtctl          ! Print control 
     32   USE lib_mpp 
    3233 
    3334   IMPLICIT NONE 
    … …  
    116117      WRITE(numout,*) '~~~~~~' 
    117118 
     119      IF( numit == nstart  )   CALL lim_thd_sal_init  ! Initialization (first time-step only) 
    118120!------------------------------------------------------------------------------! 
    119121! 1) Initialization of diagnostic variables                                    ! 
    … …  
    180182      ! 1.4) Compute global heat content 
    181183      !----------------------------------- 
    182       qt_i_in(:,:)  = 0.0 
    183       qt_s_in(:,:)  = 0.0 
    184       qt_i_fin(:,:)  = 0.0 
    185       qt_s_fin(:,:)  = 0.0 
    186       sum_fluxq(:,:) = 0.0 
    187       fatm(:,:) = 0.0 
     184      qt_i_in(:,:)  = 0.e0 
     185      qt_s_in(:,:)  = 0.e0 
     186      qt_i_fin(:,:)  = 0.e0 
     187      qt_s_fin(:,:)  = 0.e0 
     188      sum_fluxq(:,:) = 0.e0 
     189      fatm(:,:) = 0.e0 
    188190 
    189191! 2) Partial computation of forcing for the thermodynamic sea ice model.      ! 
    … …  
    279281!------------------------------------------------------------------------------! 
    280282 
     283         IF( lk_mpp ) CALL mpp_ini_ice(nbpb) 
     284 
    281285         IF (nbpb > 0) THEN  ! If there is no ice, do nothing. 
    282286 
    … …  
    414418            !+++++ 
    415419 
     420         IF( lk_mpp ) CALL mpp_comm_free(ncomm_ice) !RB necessary ?? 
    416421         ENDIF ! nbpb 
    417422 

  • trunk/NEMO/LIM_SRC_3/limthd_dh.F90

    r842 r869  
    2222   USE ice 
    2323   USE par_ice 
     24   USE lib_mpp 
    2425       
    2526   IMPLICIT NONE 
    … …  
    280281      ! Update total snow heat content 
    281282      zqt_s(ji)         =  MAX ( zqt_s(ji) - zqfont_su(ji) , 0.0 )  
     283      IF( lk_mpp ) CALL mpp_max(zqt_s(ji), kcom = ncomm_ice )  
    282284 
    283285      ! Snow melt due to surface heat imbalance 

  • trunk/NEMO/LIM_SRC_3/limthd_dif.F90

    r864 r869  
    2121   USE ice 
    2222   USE par_ice 
     23   USE lib_mpp  
    2324  
    2425   IMPLICIT NONE 
    … …  
    341342          zerrit(ji)           =  1000.0     ! initial value of error 
    342343       END DO 
     344!RB Min global ?? 
    343345 
    344346       ! Old snow temperature 
    … …  
    790792             zerritmax           =  MAX(zerritmax,zerrit(ji))    
    791793          END DO 
     794          IF( lk_mpp ) CALL mpp_max(zerritmax, kcom=ncomm_ice) 
    792795 
    793796      END DO  ! End of the do while iterative procedure 
    … …  
    795798      WRITE(numout,*) ' zerritmax : ', zerritmax 
    796799      WRITE(numout,*) ' nconv     : ', nconv 
     800 
    797801 
    798802! 

  • trunk/NEMO/LIM_SRC_3/limthd_ent.F90

    r834 r869  
    2525   USE limvar 
    2626   USE par_ice 
     27   USE lib_mpp  
    2728 
    2829   IMPLICIT NONE 
    … …  
    308309        maxnbot0           =  MAX ( maxnbot0 , nbot0(ji) ) 
    309310      ENDDO  
     311      IF( lk_mpp ) CALL mpp_max( maxnbot0, kcom=ncomm_ice ) 
    310312 
    311313      DO jk = 1, maxnbot0 

  • trunk/NEMO/LIM_SRC_3/limthd_sal.F90

    r842 r869  
    2929   !! * Routine accessibility 
    3030   PUBLIC lim_thd_sal        ! called by lim_thd 
     31   PUBLIC lim_thd_sal_init   ! called by lim_thd 
    3132 
    3233   !! * Module variables 
    … …  
    102103      !!--------------------------------------------------------------------- 
    103104 
    104       IF ( ( numit == nstart ) .AND. ( jl == 1 ) ) & 
    105          CALL lim_thd_sal_init   ! Initialization 
    106  
    107105!------------------------------------------------------------------------------| 
    108106! 1) Constant salinity, constant in time                                       | 

  • trunk/NEMO/LIM_SRC_3/limupdate.F90

    r867 r869  
    942942! Ice drift 
    943943!------------ 
    944       DO jj = 2, jpj - 1 
    945          DO ji = 2, jpim1 
     944 
     945!RB had to split the loop for mpp reproducibility, why ??? 
     946      DO jj = 1, jpj 
     947         DO ji = 1, jpim1 
    946948            IF ( at_i(ji,jj) .EQ. 0.0 ) THEN ! what to do if there is no ice 
    947949               ! mask u 
    948950               IF ( at_i(ji+1,jj) .EQ. 0.0 ) u_ice(ji,jj)   = 0.0 ! right side 
     951            ENDIF 
     952         END DO 
     953      END DO 
     954      DO jj = 1, jpj  
     955         DO ji = 2, jpi 
     956            IF ( at_i(ji,jj) .EQ. 0.0 ) THEN ! what to do if there is no ice 
     957               ! mask u 
    949958               IF ( at_i(ji-1,jj) .EQ. 0.0 ) u_ice(ji-1,jj) = 0.0 ! left side 
     959            ENDIF 
     960         END DO 
     961      END DO 
     962      DO jj = 1, jpj - 1 
     963         DO ji = 1, jpi 
     964            IF ( at_i(ji,jj) .EQ. 0.0 ) THEN ! what to do if there is no ice 
     965               ! mask u 
    950966               IF ( at_i(ji,jj+1) .EQ. 0.0 ) v_ice(ji,jj)   = 0.0 ! upper side 
     967            ENDIF 
     968         END DO 
     969      END DO 
     970      DO jj = 2, jpj  
     971         DO ji = 1, jpi 
     972            IF ( at_i(ji,jj) .EQ. 0.0 ) THEN ! what to do if there is no ice 
     973               ! mask u 
    951974               IF ( at_i(ji,jj-1) .EQ. 0.0 ) v_ice(ji-1,jj) = 0.0 ! bottom side 
    952975            ENDIF 

  • trunk/NEMO/LIM_SRC_3/limwri.F90

    r834 r869  
    141141         niter    = 0 
    142142         zdept(1) = 0. 
    143           
     143 
    144144         CALL ymds2ju ( nyear, nmonth, nday, zsec, zjulian ) 
    145145         CALL dia_nam ( clhstnam, nwrite, 'icemod' ) 
    146          CALL histbeg ( clhstnam, jpi, glamt, jpj, gphit, 1, jpi, 1, jpj, 0, zjulian, rdt_ice, nhorid, nice ) 
     146         CALL histbeg ( clhstnam, jpi, glamt, jpj, gphit, 1, jpi, 1, jpj, 0, zjulian, rdt_ice, nhorid, nice, domain_id=nidom ) 
    147147         CALL histvert( nice, "deptht", "Vertical T levels", "m", 1, zdept, ndepid) 
    148148         CALL wheneq  ( jpij , tmask(:,:,1), 1, 1., ndex51, ndim) 
    … …  
    175175                        0, zjulian, rdt_ice,   & ! time 
    176176                        nhorida,               & ! ? linked with horizontal ... 
    177                         nicea )                  ! file  
     177                        nicea , domain_id=nidom)                  ! file  
    178178         CALL histvert( nicea, "icethi", "L levels",               & 
    179179                        "m", ipl , hi_mean , nz ) 

  • trunk/NEMO/OPA_SRC/SBC/flx_bulk_daily.h90

    r841 r869  
    192192      tatm_ice(:,:) = tatm(:,:) 
    193193#endif 
     194      CALL lbc_lnk(tatm_ice, 'T', 1. )  !RB necessary ?? 
    194195       
    195196      CALL FLUSH(numout) 

  • trunk/NEMO/OPA_SRC/SBC/flx_bulk_monthly.h90

    r841 r869  
    231231      tatm_ice(:,:) = tatm(:,:) 
    232232#endif 
     233      CALL lbc_lnk(tatm_ice, 'T', 1. )  !RB necessary ?? 
    233234 
    234235      ! ------------------- ! 

  • trunk/NEMO/OPA_SRC/SBC/taumod.F90

    r841 r869  
    3333   REAL(wp), PUBLIC, DIMENSION(jpi,jpj) ::   & 
    3434      taux, tauy,      &  !: surface stress components in (i,j) referential 
    35       ! TAU BUG 
    3635#if defined key_lim3 
    3736      tauxw, tauyw,    &  !: surface wind stress components in (i,j) referential 

  • trunk/NEMO/OPA_SRC/lbclnk.F90

    r719 r869  
    410410         CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    411411 
    412             pt3d( 1 ,jpj,jk) = 0.e0 
    413             pt3d(jpi,jpj,jk) = 0.e0 
     412!            pt3d( 1 ,jpj,jk) = 0.e0 
     413!            pt3d(jpi,jpj,jk) = 0.e0 
    414414 
    415415            SELECT CASE ( cd_type ) 
    … …  
    584584      CASE ( 3 , 4 )                           ! * North fold  T-point pivot 
    585585 
    586          pt2d( 1 , 1 ) = 0.e0        !!!!!  bug gm ??? !Edmee 
    587          pt2d( 1 ,jpj) = 0.e0 
    588          pt2d(jpi,jpj) = 0.e0 
     586!         pt2d( 1 , 1 ) = 0.e0        !!!!!  bug gm ??? !Edmee 
     587!         pt2d( 1 ,jpj) = 0.e0 
     588!         pt2d(jpi,jpj) = 0.e0 
    589589 
    590590         SELECT CASE ( cd_type ) 

  • trunk/NEMO/OPA_SRC/lib_mpp.F90

    r719 r869  
    6060   PUBLIC  mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum,  mpp_lbc_north 
    6161   PUBLIC  mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_3d_gather, mpp_lnk_2d_e, mpplnks 
    62    PUBLIC  mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync 
     62   PUBLIC  mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync, mpp_ini_ice, mpp_comm_free 
    6363#if defined key_oasis3 || defined key_oasis4 
    6464   PUBLIC  mppsize, mpprank 
    … …  
    113113      mpi_comm_opa ! opa local communicator 
    114114 
     115   ! variables used in case of sea-ice 
     116   INTEGER, PUBLIC ::  &       ! 
     117      ngrp_ice,        &       ! group ID for the ice processors (to compute rheology) 
     118      ncomm_ice,       &       ! communicator made by the processors with sea-ice 
     119      ndim_rank_ice,   &       ! number of 'ice' processors 
     120      n_ice_root               ! number (in the comm_ice) of proc 0 in the ice comm 
     121   INTEGER, DIMENSION(:), ALLOCATABLE ::   & 
     122      nrank_ice            ! dimension ndim_rank_north, number of the procs belonging to ncomm_north 
    115123   ! variables used in case of north fold condition in mpp_mpi with jpni > 1 
    116124   INTEGER ::      &       ! 
    … …  
    853861 
    854862      CASE ( 1 )  ! only one proc along I, no mpp exchange 
    855  
     863        
    856864         SELECT CASE ( npolj ) 
    857865   
    … …  
    872880                  END DO 
    873881               END DO 
    874            
     882 
    875883            CASE ( 'U' ) 
    876884               DO jk = 1, jpk 
    … …  
    30693077 
    30703078 
    3071    SUBROUTINE mppmax_a_int( ktab, kdim ) 
     3079   SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 
    30723080      !!---------------------------------------------------------------------- 
    30733081      !!                  ***  routine mppmax_a_int  *** 
    … …  
    30793087      INTEGER , INTENT( in  )                  ::   kdim        ! size of array 
    30803088      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array 
     3089      INTEGER , INTENT(in), OPTIONAL         ::   kcom   
    30813090   
    30823091#if defined key_mpp_shmem 
    … …  
    31103119      !! * Local variables   (MPI version) 
    31113120      INTEGER :: ierror 
     3121      INTEGER :: localcomm 
    31123122      INTEGER, DIMENSION(kdim) ::   iwork 
     3123 
     3124      localcomm = mpi_comm_opa 
     3125      IF( PRESENT(kcom) ) localcomm = kcom 
    31133126   
    31143127      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer,   & 
    3115            &                mpi_max, mpi_comm_opa, ierror ) 
     3128           &                mpi_max, localcomm, ierror ) 
    31163129   
    31173130      ktab(:) = iwork(:) 
    … …  
    31213134 
    31223135 
    3123    SUBROUTINE mppmax_int( ktab ) 
     3136   SUBROUTINE mppmax_int( ktab, kcom ) 
    31243137      !!---------------------------------------------------------------------- 
    31253138      !!                  ***  routine mppmax_int  *** 
    … …  
    31323145      !! * Arguments 
    31333146      INTEGER, INTENT(inout) ::   ktab      ! ??? 
     3147      INTEGER, INTENT(in), OPTIONAL ::   kcom      ! ??? 
    31343148   
    31353149      !! * Local declarations 
    … …  
    31593173      !! * Local variables   (MPI version) 
    31603174      INTEGER ::  ierror, iwork 
    3161    
     3175      INTEGER :: localcomm 
     3176 
     3177      localcomm = mpi_comm_opa  
     3178      IF( PRESENT(kcom) ) localcomm = kcom 
     3179 
    31623180      CALL mpi_allreduce(ktab,iwork, 1,mpi_integer   & 
    3163            &              ,mpi_max,mpi_comm_opa,ierror) 
     3181           &              ,mpi_max,localcomm,ierror) 
    31643182   
    31653183      ktab = iwork 
    … …  
    31693187 
    31703188 
    3171    SUBROUTINE mppmin_a_int( ktab, kdim ) 
     3189   SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 
    31723190      !!---------------------------------------------------------------------- 
    31733191      !!                  ***  routine mppmin_a_int  *** 
    … …  
    31793197      INTEGER , INTENT( in  )                  ::   kdim        ! size of array 
    31803198      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array 
     3199      INTEGER , INTENT(in), OPTIONAL        ::   kcom        ! input array 
    31813200   
    31823201#if defined key_mpp_shmem 
    … …  
    32103229      !! * Local variables   (MPI version) 
    32113230      INTEGER :: ierror 
     3231      INTEGER :: localcomm 
    32123232      INTEGER, DIMENSION(kdim) ::   iwork 
    32133233   
     3234      localcomm = mpi_comm_opa 
     3235      IF( PRESENT(kcom) ) localcomm = kcom 
     3236 
    32143237      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer,   & 
    3215            &                mpi_min, mpi_comm_opa, ierror ) 
     3238           &                mpi_min, localcomm, ierror ) 
    32163239   
    32173240      ktab(:) = iwork(:) 
    … …  
    35053528 
    35063529 
    3507   SUBROUTINE mppmax_a_real( ptab, kdim ) 
     3530  SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
    35083531    !!---------------------------------------------------------------------- 
    35093532    !!                 ***  routine mppmax_a_real  *** 
    … …  
    35153538    INTEGER , INTENT( in  )                  ::   kdim 
    35163539    REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
     3540    INTEGER , INTENT( in  ), OPTIONAL     ::   kcom 
    35173541 
    35183542#if defined key_mpp_shmem 
    … …  
    35473571    !! * Local variables   (MPI version) 
    35483572    INTEGER :: ierror 
     3573    INTEGER :: localcomm 
    35493574    REAL(wp), DIMENSION(kdim) ::  zwork 
    35503575 
     3576    localcomm = mpi_comm_opa 
     3577    IF( PRESENT(kcom) ) localcomm = kcom 
     3578 
    35513579    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3552          ,mpi_max,mpi_comm_opa,ierror) 
     3580         ,mpi_max,localcomm,ierror) 
    35533581    ptab(:) = zwork(:) 
    35543582 
    … …  
    35583586 
    35593587 
    3560   SUBROUTINE mppmax_real( ptab ) 
     3588  SUBROUTINE mppmax_real( ptab, kcom ) 
    35613589    !!---------------------------------------------------------------------- 
    35623590    !!                  ***  routine mppmax_real  *** 
    … …  
    35673595    !! * Arguments 
    35683596    REAL(wp), INTENT(inout) ::   ptab      ! ??? 
     3597    INTEGER, INTENT(in), OPTIONAL ::   kcom      ! ??? 
    35693598 
    35703599#if defined key_mpp_shmem 
    … …  
    35913620    !! * Local variables   (MPI version) 
    35923621    INTEGER  ::   ierror 
     3622    INTEGER  ::   localcomm 
    35933623    REAL(wp) ::   zwork 
    35943624 
     3625    localcomm = mpi_comm_opa  
     3626    IF( PRESENT(kcom) ) localcomm = kcom 
     3627 
    35953628    CALL mpi_allreduce( ptab, zwork  , 1             , mpi_double_precision,   & 
    3596        &                      mpi_max, mpi_comm_opa, ierror     ) 
     3629       &                      mpi_max, localcomm, ierror     ) 
    35973630    ptab = zwork 
    35983631 
    … …  
    36023635 
    36033636 
    3604   SUBROUTINE mppmin_a_real( ptab, kdim ) 
     3637  SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    36053638    !!---------------------------------------------------------------------- 
    36063639    !!                 ***  routine mppmin_a_real  *** 
    … …  
    36123645    INTEGER , INTENT( in  )                  ::   kdim 
    36133646    REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
     3647    INTEGER , INTENT( in  ), OPTIONAL        ::   kcom 
    36143648 
    36153649#if defined key_mpp_shmem 
    … …  
    36443678    !! * Local variables   (MPI version) 
    36453679    INTEGER :: ierror 
     3680    INTEGER :: localcomm  
    36463681    REAL(wp), DIMENSION(kdim) ::   zwork 
    36473682 
     3683    localcomm = mpi_comm_opa  
     3684    IF( PRESENT(kcom) ) localcomm = kcom 
     3685 
    36483686    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3649          ,mpi_min,mpi_comm_opa,ierror) 
     3687         ,mpi_min,localcomm,ierror) 
    36503688    ptab(:) = zwork(:) 
    36513689 
    … …  
    36553693 
    36563694 
    3657   SUBROUTINE mppmin_real( ptab ) 
     3695  SUBROUTINE mppmin_real( ptab, kcom ) 
    36583696    !!---------------------------------------------------------------------- 
    36593697    !!                  ***  routine mppmin_real  *** 
    … …  
    36653703    !! * Arguments 
    36663704    REAL(wp), INTENT( inout ) ::   ptab        !  
     3705    INTEGER,INTENT(in), OPTIONAL :: kcom 
    36673706 
    36683707#if defined key_mpp_shmem 
    … …  
    36903729    INTEGER  ::   ierror 
    36913730    REAL(wp) ::   zwork 
     3731    INTEGER :: localcomm 
     3732 
     3733    localcomm = mpi_comm_opa  
     3734    IF( PRESENT(kcom) ) localcomm = kcom 
    36923735 
    36933736    CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision   & 
    3694          &               ,mpi_min,mpi_comm_opa,ierror) 
     3737         &               ,mpi_min,localcomm,ierror) 
    36953738    ptab = zwork 
    36963739 
    … …  
    37003743 
    37013744 
    3702   SUBROUTINE mppsum_a_real( ptab, kdim ) 
     3745  SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
    37033746    !!---------------------------------------------------------------------- 
    37043747    !!                  ***  routine mppsum_a_real  *** 
    … …  
    37103753    INTEGER , INTENT( in )                     ::   kdim      ! size of ptab 
    37113754    REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array 
     3755    INTEGER, INTENT(in), OPTIONAL :: kcom 
    37123756 
    37133757#if defined key_mpp_shmem 
    … …  
    37423786    !! * Local variables   (MPI version) 
    37433787    INTEGER                   ::   ierror    ! temporary integer 
     3788    INTEGER                   ::   localcomm  
    37443789    REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace  
     3790     
     3791 
     3792    localcomm = mpi_comm_opa  
     3793    IF( PRESENT(kcom) ) localcomm = kcom 
    37453794 
    37463795    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3747          &              ,mpi_sum,mpi_comm_opa,ierror) 
     3796         &              ,mpi_sum,localcomm,ierror) 
    37483797    ptab(:) = zwork(:) 
    37493798 
    … …  
    37533802 
    37543803 
    3755   SUBROUTINE mppsum_real( ptab ) 
     3804  SUBROUTINE mppsum_real( ptab, kcom ) 
    37563805    !!---------------------------------------------------------------------- 
    37573806    !!                  ***  routine mppsum_real  *** 
    … …  
    37623811    !!----------------------------------------------------------------------- 
    37633812    REAL(wp), INTENT(inout) ::   ptab        ! input scalar 
     3813    INTEGER, INTENT(in), OPTIONAL :: kcom 
    37643814 
    37653815#if defined key_mpp_shmem 
    … …  
    37863836    !! * Local variables   (MPI version) 
    37873837    INTEGER  ::   ierror 
     3838    INTEGER  ::   localcomm  
    37883839    REAL(wp) ::   zwork 
    37893840 
    3790     CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision   & 
    3791          &              ,mpi_sum,mpi_comm_opa,ierror) 
     3841   localcomm = mpi_comm_opa  
     3842   IF( PRESENT(kcom) ) localcomm = kcom 
     3843  
     3844   CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision   & 
     3845         &              ,mpi_sum,localcomm,ierror) 
    37923846    ptab = zwork 
    37933847 
    … …  
    42894343  END SUBROUTINE mppobc 
    42904344 
     4345  SUBROUTINE mpp_comm_free( kcom) 
     4346 
     4347     INTEGER, INTENT(in) :: kcom 
     4348     INTEGER :: ierr 
     4349 
     4350     CALL MPI_COMM_FREE(kcom, ierr) 
     4351 
     4352  END SUBROUTINE mpp_comm_free 
     4353 
     4354 
     4355  SUBROUTINE mpp_ini_ice(pindic) 
     4356    !!---------------------------------------------------------------------- 
     4357    !!               ***  routine mpp_ini_ice  *** 
     4358    !! 
     4359    !! ** Purpose :   Initialize special communicator for ice areas 
     4360    !!      condition together with global variables needed in the ddmpp folding 
     4361    !! 
     4362    !! ** Method  : - Look for ice processors in ice routines 
     4363    !!              - Put their number in nrank_ice 
     4364    !!              - Create groups for the world processors and the ice processors 
     4365    !!              - Create a communicator for ice processors 
     4366    !! 
     4367    !! ** output 
     4368    !!      njmppmax = njmpp for northern procs 
     4369    !!      ndim_rank_ice = number of processors in the northern line 
     4370    !!      nrank_north (ndim_rank_north) = number  of the northern procs. 
     4371    !!      ngrp_world = group ID for the world processors 
     4372    !!      ngrp_ice = group ID for the ice processors 
     4373    !!      ncomm_ice = communicator for the ice procs. 
     4374    !!      n_ice_root = number (in the world) of proc 0 in the ice comm. 
     4375    !! 
     4376    !! History : 
     4377    !!        !  03-09 (J.M. Molines, MPI only ) 
     4378    !!---------------------------------------------------------------------- 
     4379#ifdef key_mpp_shmem 
     4380    CALL ctl_stop( ' mpp_ini_ice not available in SHMEM' ) 
     4381# elif key_mpp_mpi 
     4382    INTEGER, INTENT(in) :: pindic 
     4383    INTEGER :: ierr 
     4384    INTEGER :: jproc 
     4385    INTEGER :: ii,ji 
     4386    INTEGER, DIMENSION(jpnij) :: kice 
     4387    INTEGER, DIMENSION(jpnij) :: zwork 
     4388    INTEGER :: zrank 
     4389    !!---------------------------------------------------------------------- 
     4390 
     4391    ! Look for how many procs with sea-ice 
     4392    ! 
     4393    kice = 0 
     4394    DO jproc=1,jpnij 
     4395       IF(jproc == narea .AND. pindic .GT. 0) THEN 
     4396          kice(jproc) = 1     
     4397       ENDIF         
     4398    END DO 
     4399 
     4400    zwork = 0 
     4401    CALL MPI_ALLREDUCE( kice, zwork,jpnij, mpi_integer,   & 
     4402                       mpi_sum, mpi_comm_opa, ierr ) 
     4403    ndim_rank_ice = sum(zwork)           
     4404 
     4405    ! Allocate the right size to nrank_north 
     4406    IF(ALLOCATED(nrank_ice)) DEALLOCATE(nrank_ice) 
     4407    ALLOCATE(nrank_ice(ndim_rank_ice)) 
     4408 
     4409    ii = 0      
     4410    nrank_ice = 0 
     4411    DO jproc=1,jpnij 
     4412       IF(zwork(jproc) == 1) THEN 
     4413          ii = ii + 1 
     4414          nrank_ice(ii) = jproc -1  
     4415       ENDIF         
     4416    END DO 
     4417 
     4418    ! Create the world group 
     4419    CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr) 
     4420 
     4421    ! Create the ice group from the world group 
     4422    CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_ice,nrank_ice,ngrp_ice,ierr) 
     4423 
     4424    ! Create the ice communicator , ie the pool of procs with sea-ice 
     4425    CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_ice,ncomm_ice,ierr) 
     4426 
     4427    ! Find proc number in the world of proc 0 in the north 
     4428    CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr) 
     4429#endif 
     4430 
     4431  END SUBROUTINE mpp_ini_ice 
     4432 
    42914433 
    42924434  SUBROUTINE mpp_ini_north 
    … …  
    52375379 
    52385380   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
     5381   INTEGER :: ncomm_ice 
    52395382 
    52405383CONTAINS 
    … …  
    52485391   END SUBROUTINE mppsync 
    52495392 
    5250    SUBROUTINE mpp_sum_as( parr, kdim )      ! Dummy routine 
     5393   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine 
    52515394      REAL   , DIMENSION(:) :: parr 
    52525395      INTEGER               :: kdim 
    5253       WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1) 
     5396      INTEGER, OPTIONAL     :: kcom  
     5397      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom 
    52545398   END SUBROUTINE mpp_sum_as 
    52555399 
    5256    SUBROUTINE mpp_sum_a2s( parr, kdim )      ! Dummy routine 
     5400   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine 
    52575401      REAL   , DIMENSION(:,:) :: parr 
    52585402      INTEGER               :: kdim 
    5259       WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1) 
     5403      INTEGER, OPTIONAL     :: kcom  
     5404      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom 
    52605405   END SUBROUTINE mpp_sum_a2s 
    52615406 
    5262    SUBROUTINE mpp_sum_ai( karr, kdim )      ! Dummy routine 
     5407   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine 
    52635408      INTEGER, DIMENSION(:) :: karr 
    52645409      INTEGER               :: kdim 
    5265       WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1) 
     5410      INTEGER, OPTIONAL     :: kcom  
     5411      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom 
    52665412   END SUBROUTINE mpp_sum_ai 
    52675413 
    5268    SUBROUTINE mpp_sum_s( psca )            ! Dummy routine 
     5414   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine 
    52695415      REAL                  :: psca 
    5270       WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca 
     5416      INTEGER, OPTIONAL     :: kcom  
     5417      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 
    52715418   END SUBROUTINE mpp_sum_s 
    52725419 
    5273    SUBROUTINE mpp_sum_i( kint )            ! Dummy routine 
     5420   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine 
    52745421      integer               :: kint 
    5275       WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint 
     5422      INTEGER, OPTIONAL     :: kcom  
     5423      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 
    52765424   END SUBROUTINE mpp_sum_i 
    52775425 
    5278    SUBROUTINE mppmax_a_real( parr, kdim ) 
     5426   SUBROUTINE mppmax_a_real( parr, kdim, kcom ) 
    52795427      REAL   , DIMENSION(:) :: parr 
    52805428      INTEGER               :: kdim 
    5281       WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1) 
     5429      INTEGER, OPTIONAL     :: kcom  
     5430      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 
    52825431   END SUBROUTINE mppmax_a_real 
    52835432 
    5284    SUBROUTINE mppmax_real( psca ) 
     5433   SUBROUTINE mppmax_real( psca, kcom ) 
    52855434      REAL                  :: psca 
    5286       WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca 
     5435      INTEGER, OPTIONAL     :: kcom  
     5436      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom 
    52875437   END SUBROUTINE mppmax_real 
    52885438 
    5289    SUBROUTINE mppmin_a_real( parr, kdim ) 
     5439   SUBROUTINE mppmin_a_real( parr, kdim, kcom ) 
    52905440      REAL   , DIMENSION(:) :: parr 
    52915441      INTEGER               :: kdim 
    5292       WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1) 
     5442      INTEGER, OPTIONAL     :: kcom  
     5443      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 
    52935444   END SUBROUTINE mppmin_a_real 
    52945445 
    5295    SUBROUTINE mppmin_real( psca ) 
     5446   SUBROUTINE mppmin_real( psca, kcom ) 
    52965447      REAL                  :: psca 
    5297       WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca 
     5448      INTEGER, OPTIONAL     :: kcom  
     5449      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom 
    52985450   END SUBROUTINE mppmin_real 
    52995451 
    5300    SUBROUTINE mppmax_a_int( karr, kdim ) 
     5452   SUBROUTINE mppmax_a_int( karr, kdim ,kcom) 
    53015453      INTEGER, DIMENSION(:) :: karr 
    53025454      INTEGER               :: kdim 
     5455      INTEGER, OPTIONAL     :: kcom  
    53035456      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1) 
    53045457   END SUBROUTINE mppmax_a_int 
    53055458 
    5306    SUBROUTINE mppmax_int( kint ) 
     5459   SUBROUTINE mppmax_int( kint, kcom) 
    53075460      INTEGER               :: kint 
    5308       WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint 
     5461      INTEGER, OPTIONAL     :: kcom  
     5462      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom 
    53095463   END SUBROUTINE mppmax_int 
    53105464 
    5311    SUBROUTINE mppmin_a_int( karr, kdim ) 
     5465   SUBROUTINE mppmin_a_int( karr, kdim, kcom ) 
    53125466      INTEGER, DIMENSION(:) :: karr 
    53135467      INTEGER               :: kdim 
    5314       WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1) 
     5468      INTEGER, OPTIONAL     :: kcom  
     5469      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 
    53155470   END SUBROUTINE mppmin_a_int 
    53165471 
    5317    SUBROUTINE mppmin_int( kint ) 
     5472   SUBROUTINE mppmin_int( kint, kcom ) 
    53185473      INTEGER               :: kint 
    5319       WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint 
     5474      INTEGER, OPTIONAL     :: kcom  
     5475      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 
    53205476   END SUBROUTINE mppmin_int 
    53215477 
    … …  
    54125568   END SUBROUTINE mppstop 
    54135569 
     5570   SUBROUTINE mpp_ini_lim 
     5571      WRITE(*,*) 'mpp_ini_north: You should not have seen this print! error?' 
     5572   END SUBROUTINE mpp_ini_lim 
     5573 
     5574   SUBROUTINE mpp_comm_free(kcom) 
     5575      INTEGER :: kcom 
     5576      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?' 
     5577   END SUBROUTINE mpp_comm_free 
     5578 
    54145579#endif 
    54155580   !!---------------------------------------------------------------------- 
Note: See TracChangeset for help on using the changeset viewer.