Changeset 5579


Ignore:
Timestamp:
2015-07-09T18:07:16+02:00 (5 years ago)
Author:
mcastril
Message:

ticket #1539 Performance optimizations on NEMO 3.6 limhdf routine

Location:
branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r5429 r5579  
    2828 
    2929   PUBLIC   lim_hdf         ! called by lim_trp 
     30   PUBLIC   lim_hdf_multiple ! called by lim_trp 
    3031   PUBLIC   lim_hdf_init    ! called by sbc_lim_init 
    3132 
     
    124125         CALL lbc_lnk( zrlx, 'T', 1. )                   ! lateral boundary condition 
    125126         ! 
    126          IF ( MOD( iter, nn_convfrq ) == 0 )  THEN    ! convergence test every nn_convfrq iterations (perf. optimization) 
     127         IF ( MOD( iter - 1 , nn_convfrq ) == 0 )  THEN    ! convergence test every nn_convfrq iterations (perf. optimization) 
    127128            zconv = 0._wp 
    128129            DO jj = 2, jpjm1 
     
    166167      ! 
    167168   END SUBROUTINE lim_hdf 
     169    
     170 
     171   SUBROUTINE lim_hdf_multiple( ptab , ihdf_vars , jpl , nlay_i ) 
     172      !!------------------------------------------------------------------- 
     173      !!                  ***  ROUTINE lim_hdf  *** 
     174      !! 
     175      !! ** purpose :   Compute and add the diffusive trend on sea-ice variables 
     176      !! 
     177      !! ** method  :   Second order diffusive operator evaluated using a 
     178      !!              Cranck-Nicholson time Scheme. 
     179      !! 
     180      !! ** Action  :    update ptab with the diffusive contribution 
     181      !!------------------------------------------------------------------- 
     182      INTEGER                           :: jpl, nlay_i, isize, ihdf_vars 
     183      REAL(wp),  DIMENSION(:,:,:), INTENT( inout ),TARGET ::   ptab    ! Field on which the diffusion is applied 
     184      REAL(wp), POINTER, DIMENSION(:,:,:)        ::   pahu3D , pahv3D 
     185      ! 
     186      INTEGER                           ::  ji, jj, jk, jl , jm               ! dummy loop indices 
     187      INTEGER                           ::  iter, ierr           ! local integers 
     188      REAL(wp)                          ::  zrlxint     ! local scalars 
     189      REAL(wp), POINTER , DIMENSION ( : )        :: zconv     ! local scalars 
     190      REAL(wp), POINTER , DIMENSION(:,:,:) ::  zrlx,zdiv0, ztab0 
     191      REAL(wp), POINTER , DIMENSION(:,:) ::  zflu, zflv, zdiv 
     192      CHARACTER(lc)                     ::  charout                   ! local character 
     193      REAL(wp), PARAMETER               ::  zrelax = 0.5_wp           ! relaxation constant for iterative procedure 
     194      REAL(wp), PARAMETER               ::  zalfa  = 0.5_wp           ! =1.0/0.5/0.0 = implicit/Cranck-Nicholson/explicit 
     195      INTEGER , PARAMETER               ::  its    = 100              ! Maximum number of iteration 
     196      !!------------------------------------------------------------------- 
     197      TYPE(arrayptr)   , ALLOCATABLE, DIMENSION(:) ::   pt2d_array, zrlx_array 
     198      CHARACTER(len=1) , ALLOCATABLE, DIMENSION(:) ::   type_array ! define the nature of ptab array grid-points 
     199      !                                                            ! = T , U , V , F , W and I points 
     200      REAL(wp)        , ALLOCATABLE, DIMENSION(:)  ::   psgn_array    ! =-1 the sign change across the north fold boundary 
     201 
     202     !!---------------------------------------------------------------------  
     203 
     204      !                       !==  Initialisation  ==! 
     205         isize = jpl*(ihdf_vars+nlay_i) 
     206      ALLOCATE( zconv (isize) ) 
     207      ALLOCATE( pt2d_array(isize) , zrlx_array(isize) ) 
     208      ALLOCATE( type_array(isize) ) 
     209      ALLOCATE( psgn_array(isize) ) 
     210       
     211      CALL wrk_alloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
     212      CALL wrk_alloc( jpi, jpj, zflu, zflv, zdiv ) 
     213      CALL wrk_alloc( jpi, jpj, jpl, pahu3D , pahv3D ) 
     214 
     215 
     216      DO jl = 1 , jpl 
     217         jm = (jl-1)*(ihdf_vars+nlay_i)+1 
     218         DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
     219            DO ji = 1 , fs_jpim1   ! vector opt. 
     220               pahu3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -ptab(ji  ,jj,jm) ) ) )   & 
     221               &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -ptab(ji+1, jj, jm ) ) ) ) * ahiu(ji,jj) 
     222               pahv3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -ptab(ji, jj, jm ) ) ) )   & 
     223               &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- ptab(ji, jj+1, jm ) ) ) ) * ahiv(ji,jj) 
     224            END DO 
     225         END DO 
     226      END DO 
     227 
     228      DO jk= 1 , isize 
     229         pt2d_array(jk)%pt2d=>ptab(:,:,jk) 
     230         zrlx_array(jk)%pt2d=>zrlx(:,:,jk) 
     231         type_array(jk)='T' 
     232         psgn_array(jk)=1. 
     233      END DO 
     234 
     235      ! 
     236      IF( linit ) THEN              ! Metric coefficient (compute at the first call and saved in efact) 
     237         ALLOCATE( efact(jpi,jpj) , STAT=ierr ) 
     238         IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     239         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'lim_hdf : unable to allocate arrays' ) 
     240         DO jj = 2, jpjm1 
     241            DO ji = fs_2 , fs_jpim1   ! vector opt. 
     242               efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) * r1_e12t(ji,jj) 
     243            END DO 
     244         END DO 
     245         linit = .FALSE. 
     246      ENDIF 
     247      !                             ! Time integration parameters 
     248      ! 
     249      zflu (jpi,: ) = 0._wp 
     250      zflv (jpi,: ) = 0._wp 
     251 
     252      DO jk=1 , isize 
     253         ztab0(:, : , jk ) = ptab(:,:,jk)      ! Arrays initialization 
     254         zdiv0(:, 1 , jk ) = 0._wp 
     255         zdiv0(:,jpj, jk ) = 0._wp 
     256         zdiv0(1,  :, jk ) = 0._wp 
     257         zdiv0(jpi,:, jk ) = 0._wp 
     258      END DO 
     259 
     260      zconv = 1._wp           !==  horizontal diffusion using a Crant-Nicholson scheme  ==! 
     261      iter  = 0 
     262      ! 
     263      DO WHILE( MAXVAL(zconv(:)) > ( 2._wp * 1.e-04 ) .AND. iter <= its )   ! Sub-time step loop 
     264         ! 
     265         iter = iter + 1                                 ! incrementation of the sub-time step number 
     266         ! 
     267 
     268         DO jk = 1 , isize 
     269            jl = (jk-1) /( ihdf_vars+nlay_i)+1 
     270            IF (zconv(jk) > ( 2._wp * 1.e-04 )) THEN 
     271               DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
     272                  DO ji = 1 , fs_jpim1   ! vector opt. 
     273                     zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 
     274                     zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 
     275                  END DO 
     276               END DO 
     277               ! 
     278               DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
     279                  DO ji = fs_2 , fs_jpim1   ! vector opt.  
     280                     zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
     281                  END DO 
     282               END DO 
     283               ! 
     284               IF( iter == 1 )   zdiv0(:,:,jk) = zdiv(:,:)        ! save the 1st evaluation of the diffusive trend in zdiv0 
     285               ! 
     286               DO jj = 2, jpjm1                                ! iterative evaluation 
     287                  DO ji = fs_2 , fs_jpim1   ! vector opt. 
     288                     zrlxint = (   ztab0(ji,jj,jk)    & 
     289                        &       +  rdt_ice * (           zalfa   * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj,jk) )   & 
     290                        &                      + ( 1.0 - zalfa ) *   zdiv0(ji,jj,jk) )                               & 
     291                        &      ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 
     292                     zrlx(ji,jj,jk) = ptab(ji,jj,jk) + zrelax * ( zrlxint - ptab(ji,jj,jk) ) 
     293                  END DO 
     294               END DO 
     295            END IF 
     296 
     297         END DO 
     298 
     299         CALL lbc_lnk_multi( zrlx_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     300         ! 
     301          
     302         IF ( MOD( iter-1 , nn_convfrq ) == 0 )  THEN   !Convergence test every nn_convfrq iterations (perf. optimization )  
     303            DO jk=1,isize 
     304               zconv(jk) = 0._wp                                   ! convergence test 
     305               DO jj = 2, jpjm1 
     306                  DO ji = fs_2, fs_jpim1 
     307                     zconv(jk) = MAX( zconv(jk), ABS( zrlx(ji,jj,jk) - ptab(ji,jj,jk) )  ) 
     308                  END DO 
     309               END DO 
     310            END DO 
     311            IF( lk_mpp ) CALL mpp_max_multiple( zconv , isize )            ! max over the global domain for all the variables 
     312         ENDIF 
     313         ! 
     314         DO jk=1,isize 
     315            ptab(:,:,jk) = zrlx(:,:,jk) 
     316         END DO 
     317         ! 
     318      END DO                                       ! end of sub-time step loop 
     319 
     320     ! ----------------------- 
     321      !!! final step (clem) !!! 
     322      DO jk = 1, isize 
     323         jl = (jk-1) /( ihdf_vars+nlay_i)+1 
     324         DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
     325            DO ji = 1 , fs_jpim1   ! vector opt. 
     326               zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 
     327               zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 
     328            END DO 
     329         END DO 
     330         ! 
     331         DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
     332            DO ji = fs_2 , fs_jpim1   ! vector opt.  
     333               zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
     334               ptab(ji,jj,jk) = ztab0(ji,jj,jk) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj,jk) ) 
     335            END DO 
     336         END DO 
     337      END DO 
     338 
     339      CALL lbc_lnk_multi( pt2d_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     340 
     341      !!! final step (clem) !!! 
     342      ! ----------------------- 
     343 
     344      IF(ln_ctl)   THEN 
     345         DO jk = 1 , isize 
     346            zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 
     347            WRITE(charout,FMT="(' lim_hdf  : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 
     348            CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 
     349         END DO 
     350      ENDIF 
     351      ! 
     352      CALL wrk_dealloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
     353      CALL wrk_dealloc( jpi, jpj, zflu, zflv, zdiv ) 
     354      CALL wrk_dealloc( jpi, jpj, jpl, pahu3D , pahv3D ) 
     355 
     356      DEALLOCATE( zconv ) 
     357      DEALLOCATE( pt2d_array , zrlx_array ) 
     358      DEALLOCATE( type_array ) 
     359      DEALLOCATE( psgn_array ) 
     360      ! 
     361   END SUBROUTINE lim_hdf_multiple 
     362 
    168363 
    169364    
     
    179374      !!------------------------------------------------------------------- 
    180375      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    181       NAMELIST/namicehdf/ nn_convfrq 
     376      NAMELIST/namicehdf/ nn_convfrq  
    182377      !!------------------------------------------------------------------- 
    183378      ! 
  • branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90

    r5202 r5579  
    6363      INTEGER, INTENT(in) ::   kt           ! number of iteration 
    6464      ! 
    65       INTEGER  ::   ji, jj, jk, jl, jt      ! dummy loop indices 
     65      INTEGER  ::   ji, jj, jk, jm , jl, jt      ! dummy loop indices 
    6666      INTEGER  ::   initad                  ! number of sub-timestep for the advection 
    6767      REAL(wp) ::   zcfl , zusnit           !   -      - 
     
    7575      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   zhimax                   ! old ice thickness 
    7676      REAL(wp), POINTER, DIMENSION(:,:)      ::   zatold, zeiold, zesold   ! old concentration, enthalpies 
     77      REAL(wp), POINTER, DIMENSION(:,:,:)             ::   zhdfptab 
    7778      REAL(wp) ::    zdv, zvi, zvs, zsmv, zes, zei 
    7879      REAL(wp) ::    zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 
     80      !!--------------------------------------------------------------------- 
     81      INTEGER                                ::  ihdf_vars  = 6  !!Number of variables in which we apply horizontal diffusion 
     82                                                                   !!  inside limtrp for each ice category , not counting the  
     83                                                                   !!  variables corresponding to ice_layers  
    7984      !!--------------------------------------------------------------------- 
    8085      IF( nn_timing == 1 )  CALL timing_start('limtrp') 
     
    8590      CALL wrk_alloc( jpi,jpj,nlay_i,jpl, z0ei ) 
    8691      CALL wrk_alloc( jpi,jpj,jpl,        zhimax, zviold, zvsold, zsmvold ) 
     92      CALL wrk_alloc( jpi,jpj,jpl*(ihdf_vars + nlay_i),zhdfptab) 
    8793 
    8894      IF( numit == nstart .AND. lwp ) THEN 
     
    170176            z0oi (:,:,jl)   = oa_i (:,:,jl) * e12t(:,:)    ! Age content 
    171177            z0es (:,:,jl)   = e_s  (:,:,1,jl) * e12t(:,:)  ! Snow heat content 
    172             DO jk = 1, nlay_i 
     178           DO jk = 1, nlay_i 
    173179               z0ei  (:,:,jk,jl) = e_i  (:,:,jk,jl) * e12t(:,:) ! Ice  heat content 
    174180            END DO 
     
    305311         !------------------------------------ 
    306312         DO jl = 1, jpl 
    307          !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
    308             DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
    309                DO ji = 1 , fs_jpim1   ! vector opt. 
    310                   pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,jl) ) ) )   & 
    311                      &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 
    312                   pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj  ,jl) ) ) )   & 
    313                      &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 
    314                END DO 
    315             END DO 
    316  
    317             CALL lim_hdf( v_i  (:,:,  jl) ) 
    318             CALL lim_hdf( v_s  (:,:,  jl) ) 
    319             CALL lim_hdf( smv_i(:,:,  jl) ) 
    320             CALL lim_hdf( oa_i (:,:,  jl) ) 
    321             CALL lim_hdf( a_i  (:,:,  jl) ) 
    322             CALL lim_hdf( e_s  (:,:,1,jl) ) 
     313            jm=(jl-1)*(ihdf_vars+nlay_i)+1 
     314            zhdfptab(:,:,jm)= a_i  (:,:,  jl); jm = jm + 1   ! IMPORTANT  a_i must go in the first position because  
     315                                                             ! it is needed at this position inside lim_hdf_multiple. 
     316            zhdfptab(:,:,jm)= v_i  (:,:,  jl); jm = jm + 1 
     317            zhdfptab(:,:,jm)= v_s  (:,:,  jl); jm = jm + 1  
     318            zhdfptab(:,:,jm)= smv_i(:,:,  jl); jm = jm + 1 
     319            zhdfptab(:,:,jm)= oa_i (:,:,  jl); jm = jm + 1 
     320            zhdfptab(:,:,jm)= e_s  (:,:,1,jl); jm = jm + 1 
     321         ! Sample of adding more variables to apply lim_hdf using lim_hdf_multiple optimization--- 
     322         !   zhdfptab(:,:,jm) = variable_1 (:,:,1,jl); jm = jm + 1   
     323         !   zhdfptab(:,:,jm) = variable_2 (:,:,1,jl); jm = jm + 1  
     324         ! 
     325         ! and in this example the parameter ihdf_vars musb be changed to 8 (necessary for allocation) 
     326         !---------------------------------------------------------------------------------------- 
    323327            DO jk = 1, nlay_i 
    324                CALL lim_hdf( e_i(:,:,jk,jl) ) 
    325             END DO 
    326          END DO 
     328              zhdfptab(:,:,jm)=e_i(:,:,jk,jl); jm= jm+1 
     329            END DO 
     330         END DO 
     331         CALL lim_hdf_multiple( zhdfptab, ihdf_vars, jpl, nlay_i)  
     332 
     333         DO jl = 1, jpl 
     334            jm=(jl-1)*(ihdf_vars+nlay_i)+1 
     335            a_i  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1       
     336            v_i  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     337            v_s  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     338            smv_i(:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     339            oa_i (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     340            e_s  (:,:,1,jl) = zhdfptab(:,:,jm); jm = jm + 1  
     341         ! Sample of adding more variables to apply lim_hdf--------- 
     342         !   variable_1  (:,:,1,jl) = zhdfptab(:,:, jm  ) ; jm + 1  
     343         !   variable_2  (:,:,1,jl) = zhdfptab(:,:, jm  ) ; jm + 1 
     344         !----------------------------------------------------------- 
     345            DO jk = 1, nlay_i 
     346               e_i(:,:,jk,jl) = zhdfptab(:,:,jm);jm= jm + 1  
     347            END DO 
     348         END DO 
     349 
    327350 
    328351         !------------------------------------------------------------------------------! 
     
    464487      CALL wrk_dealloc( jpi,jpj,nlay_i,jpl, z0ei ) 
    465488      CALL wrk_dealloc( jpi,jpj,jpl,        zviold, zvsold, zhimax, zsmvold ) 
     489      CALL wrk_dealloc( jpi,jpj,jpl*(ihdf_vars+nlay_i),zhdfptab) 
    466490      ! 
    467491      IF( nn_timing == 1 )  CALL timing_stop('limtrp') 
  • branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r5429 r5579  
    2424 
    2525   INTERFACE lbc_lnk_multi 
    26       MODULE PROCEDURE mpp_lnk_2d_9 
     26      MODULE PROCEDURE mpp_lnk_2d_9 , mpp_lnk_2d_multiple 
    2727   END INTERFACE 
    2828 
  • branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r5429 r5579  
    6262   USE lbcnfd         ! north fold treatment 
    6363   USE in_out_manager ! I/O manager 
     64   USE wrk_nemo       ! work arrays 
    6465 
    6566   IMPLICIT NONE 
     
    7071   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    7172   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
     73   PUBLIC   mpp_max_multiple 
    7274   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    73    PUBLIC   mpp_lnk_2d_9  
     75   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    7476   PUBLIC   mppscatter, mppgather 
    7577   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    7880   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    7981   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     82   PUBLIC   mpprank 
    8083 
    8184   TYPE arrayptr 
    8285      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8386   END TYPE arrayptr 
     87   PUBLIC   arrayptr 
    8488    
    8589   !! * Interfaces 
     
    105109   INTERFACE mpp_maxloc 
    106110      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     111   END INTERFACE 
     112 
     113   INTERFACE mpp_max_multiple 
     114      MODULE PROCEDURE mppmax_real_multiple 
    107115   END INTERFACE 
    108116 
     
    724732      ! ----------------------- 
    725733      ! 
    726       DO ii = 1 , num_fields 
    727734         !First Array 
    728          IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    729             ! 
    730             SELECT CASE ( jpni ) 
    731             CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    732             CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
    733             END SELECT 
    734             ! 
    735          ENDIF 
    736          ! 
    737       END DO 
     735      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     736         ! 
     737         SELECT CASE ( jpni ) 
     738         CASE ( 1 )     ;    
     739             DO ii = 1 , num_fields   
     740                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     741             END DO 
     742         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     743         END SELECT 
     744         ! 
     745      ENDIF 
     746        ! 
    738747       
    739748      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     
    16811690   END SUBROUTINE mppmax_real 
    16821691 
     1692   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     1693      !!---------------------------------------------------------------------- 
     1694      !!                  ***  routine mppmax_real  *** 
     1695      !! 
     1696      !! ** Purpose :   Maximum 
     1697      !! 
     1698      !!---------------------------------------------------------------------- 
     1699      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     1700      INTEGER , INTENT(in   )           ::   NUM 
     1701      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     1702      !! 
     1703      INTEGER  ::   ierror, localcomm 
     1704      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     1705      !!---------------------------------------------------------------------- 
     1706      ! 
     1707      CALL wrk_alloc(NUM , zwork) 
     1708      localcomm = mpi_comm_opa 
     1709      IF( PRESENT(kcom) )   localcomm = kcom 
     1710      ! 
     1711      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1712      ptab = zwork 
     1713      CALL wrk_dealloc(NUM , zwork) 
     1714      ! 
     1715   END SUBROUTINE mppmax_real_multiple 
     1716 
    16831717 
    16841718   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
     
    25752609   END SUBROUTINE mpp_lbc_north_2d 
    25762610 
     2611   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2612      !!--------------------------------------------------------------------- 
     2613      !!                   ***  routine mpp_lbc_north_2d  *** 
     2614      !! 
     2615      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2616      !!              in mpp configuration in case of jpn1 > 1 
     2617      !!              (for multiple 2d arrays ) 
     2618      !! 
     2619      !! ** Method  :   North fold condition and mpp with more than one proc 
     2620      !!              in i-direction require a specific treatment. We gather 
     2621      !!              the 4 northern lines of the global domain on 1 processor 
     2622      !!              and apply lbc north-fold on this sub array. Then we 
     2623      !!              scatter the north fold array back to the processors. 
     2624      !! 
     2625      !!---------------------------------------------------------------------- 
     2626      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2627      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2628      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2629      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2630      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2631      !!                                                             ! =  1. , the sign is kept 
     2632      INTEGER ::   ji, jj, jr, jk 
     2633      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2634      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2635      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2636      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2637      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2638      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2639      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2640      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2641      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2642      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2643      INTEGER :: istatus(mpi_status_size) 
     2644      INTEGER :: iflag 
     2645      !!---------------------------------------------------------------------- 
     2646      ! 
     2647      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2648      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2649      ! 
     2650      ijpj   = 4 
     2651      ijpjm1 = 3 
     2652      ! 
     2653       
     2654      DO jk = 1, num_fields 
     2655         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2656            ij = jj - nlcj + ijpj 
     2657            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2658         END DO 
     2659      END DO 
     2660      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2661      itaille = jpi * ijpj 
     2662                                                                   
     2663      IF ( l_north_nogather ) THEN 
     2664         ! 
     2665         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2666         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2667         ! 
     2668         ztabr(:,:,:) = 0 
     2669         ztabl(:,:,:) = 0 
     2670 
     2671         DO jk = 1, num_fields 
     2672            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2673               ij = jj - nlcj + ijpj 
     2674               DO ji = nfsloop, nfeloop 
     2675                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     2676               END DO 
     2677            END DO 
     2678         END DO 
     2679 
     2680         DO jr = 1,nsndto 
     2681            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2682               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     2683            ENDIF 
     2684         END DO 
     2685         DO jr = 1,nsndto 
     2686            iproc = nfipproc(isendto(jr),jpnj) 
     2687            IF(iproc .ne. -1) THEN 
     2688               ilei = nleit (iproc+1) 
     2689               ildi = nldit (iproc+1) 
     2690               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2691            ENDIF 
     2692            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2693              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     2694              DO jk = 1 , num_fields 
     2695                 DO jj = 1, ijpj 
     2696                    DO ji = ildi, ilei 
     2697                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     2698                    END DO 
     2699                 END DO 
     2700              END DO 
     2701            ELSE IF (iproc .eq. (narea-1)) THEN 
     2702              DO jk = 1, num_fields 
     2703                 DO jj = 1, ijpj 
     2704                    DO ji = ildi, ilei 
     2705                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     2706                    END DO 
     2707                 END DO 
     2708              END DO 
     2709            ENDIF 
     2710         END DO 
     2711         IF (l_isend) THEN 
     2712            DO jr = 1,nsndto 
     2713               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2714                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2715               ENDIF 
     2716            END DO 
     2717         ENDIF 
     2718         ! 
     2719         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     2720            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     2721         END DO 
     2722         ! 
     2723         DO jk = 1, num_fields 
     2724            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2725               ij = jj - nlcj + ijpj 
     2726               DO ji = 1, nlci 
     2727                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     2728               END DO 
     2729            END DO 
     2730         END DO 
     2731          
     2732         ! 
     2733      ELSE 
     2734         ! 
     2735         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     2736            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2737         ! 
     2738         ztab(:,:,:) = 0.e0 
     2739         DO jk = 1, num_fields 
     2740            DO jr = 1, ndim_rank_north            ! recover the global north array 
     2741               iproc = nrank_north(jr) + 1 
     2742               ildi = nldit (iproc) 
     2743               ilei = nleit (iproc) 
     2744               iilb = nimppt(iproc) 
     2745               DO jj = 1, ijpj 
     2746                  DO ji = ildi, ilei 
     2747                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     2748                  END DO 
     2749               END DO 
     2750            END DO 
     2751         END DO 
     2752          
     2753         DO ji = 1, num_fields 
     2754            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     2755         END DO 
     2756         ! 
     2757         DO jk = 1, num_fields 
     2758            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2759               ij = jj - nlcj + ijpj 
     2760               DO ji = 1, nlci 
     2761                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     2762               END DO 
     2763            END DO 
     2764         END DO 
     2765         ! 
     2766         ! 
     2767      ENDIF 
     2768      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     2769      DEALLOCATE( ztabl, ztabr ) 
     2770      ! 
     2771   END SUBROUTINE mpp_lbc_north_2d_multiple 
    25772772 
    25782773   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
Note: See TracChangeset for help on using the changeset viewer.