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

Changeset 11067 for NEMO/branches


Ignore:
Timestamp:
2019-05-29T11:34:32+02:00 (5 years ago)
Author:
girrmann
Message:

dev_r10984_HPC-13 : new implementation of lbc_bdy_lnk in prevision of step 2, regroup communications, see #2285

Location:
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src
Files:
12 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/BDY/bdy_oce.F90

    r11024 r11067  
    139139   TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET      ::   dta_bdy           !: bdy external data (local process) 
    140140!$AGRIF_END_DO_NOT_TREAT 
     141   LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) ::   lsend_bdy !: mark needed communication for given boundary, grid and direction 
     142   LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) ::   lrecv_bdy !: mark needed communication for given boundary, grid and direction 
    141143   !!---------------------------------------------------------------------- 
    142144   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/BDY/bdydyn2d.F90

    r11049 r11067  
    5050      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pssh 
    5151      !! 
    52       INTEGER                                  ::   ib_bdy ! Loop counter 
    53  
     52      INTEGER                                  ::   ib_bdy     ! Loop counter 
     53      LOGICAL, DIMENSION(4) :: lsend2, lrecv2, lsend3, lrecv3  ! indicate how communications are to be carried out 
     54       
    5455      DO ib_bdy=1, nb_bdy 
    55  
    5656         SELECT CASE( cn_dyn2d(ib_bdy) ) 
    5757         CASE('none') 
    … …  
    7171         END SELECT 
    7272      ENDDO 
    73  
     73      ! 
     74      lsend2(:) = .false. 
     75      lrecv2(:) = .false. 
     76      lsend3(:) = .false. 
     77      lrecv3(:) = .false. 
     78      DO ib_bdy=1, nb_bdy 
     79         SELECT CASE( cn_dyn2d(ib_bdy) ) 
     80         CASE('flather') 
     81            lsend2(:) = lsend2(:) .OR. lsend_bdy(ib_bdy,2,:)   ! to   every bdy neighbour, U points 
     82            lrecv2(:) = lrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:)   ! from every bdy neighbour, U points 
     83            lsend3(:) = lsend3(:) .OR. lsend_bdy(ib_bdy,3,:)   ! to   every bdy neighbour, V points 
     84            lrecv3(:) = lrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:)   ! from every bdy neighbour, V points 
     85         CASE('orlanski') 
     86            lsend2(:) = lsend2(:) .OR. lsend_bdy(ib_bdy,2,:)   ! to   every bdy neighbour, U points 
     87            lrecv2(:) = lrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:)   ! from every bdy neighbour, U points 
     88            lsend3(:) = lsend3(:) .OR. lsend_bdy(ib_bdy,3,:)   ! to   every bdy neighbour, V points 
     89            lrecv3(:) = lrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:)   ! from every bdy neighbour, V points 
     90         CASE('orlanski_npo') 
     91            lsend2(:) = lsend2(:) .OR. lsend_bdy(ib_bdy,2,:)   ! to   every bdy neighbour, U points 
     92            lrecv2(:) = lrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:)   ! from every bdy neighbour, U points 
     93            lsend3(:) = lsend3(:) .OR. lsend_bdy(ib_bdy,3,:)   ! to   every bdy neighbour, V points 
     94            lrecv3(:) = lrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:)   ! from every bdy neighbour, V points 
     95         END SELECT 
     96      END DO 
     97      IF( ANY(lsend2) .OR. ANY(lrecv2) ) THEN   ! if need to send/recv in at least one direction 
     98         CALL lbc_bdy_lnk( 'bdydyn2d', lsend2, lrecv2, pua2d, 'U', -1. ) 
     99      END IF 
     100      IF( ANY(lsend3) .OR. ANY(lrecv3) ) THEN   ! if need to send/recv in at least one direction 
     101         CALL lbc_bdy_lnk( 'bdydyn2d', lsend3, lrecv3, pva2d, 'V', -1. ) 
     102      END IF 
     103      ! 
    74104   END SUBROUTINE bdy_dyn2d 
    75105 
    … …  
    110140         pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) 
    111141      END DO  
    112       CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )  
    113       CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy)   ! Boundary points should be updated 
    114142      ! 
    115143   END SUBROUTINE bdy_dyn2d_frs 
    … …  
    170198      END DO 
    171199 
    172       CALL lbc_bdy_lnk( 'bdydyn2d', spgu(:,:), 'T', 1., ib_bdy ) 
    173200      ! 
    174201      igrd = 2      ! Flather bc on u-velocity;  
    … …  
    210237         pva2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * vmask(ii,ij,1) 
    211238      END DO 
    212       CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
    213       CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy )   ! 
    214239      ! 
    215240   END SUBROUTINE bdy_dyn2d_fla 
    … …  
    246271      CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, ll_npo ) 
    247272      ! 
    248       CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
    249       CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy )   ! 
    250       ! 
    251273   END SUBROUTINE bdy_dyn2d_orlanski 
    252274 
    … …  
    262284      !! 
    263285      INTEGER  ::   ib_bdy          ! bdy index 
    264       !!---------------------------------------------------------------------- 
     286      LOGICAL, DIMENSION(4) :: lsend1, lrecv1  ! indicate how communications are to be carried out 
     287      !!---------------------------------------------------------------------- 
     288      lsend1(:) = .false. 
     289      lrecv1(:) = .false. 
    265290      DO ib_bdy = 1, nb_bdy 
    266291         CALL bdy_nmn( idx_bdy(ib_bdy), 1, zssh )   ! zssh is masked 
    267          CALL lbc_bdy_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1., ib_bdy ) 
    268       END DO 
     292         lsend1(:) = lsend1(:) .OR. lsend_bdy(ib_bdy,1,:)   ! to   every bdy neighbour, T points 
     293         lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:)   ! from every bdy neighbour, T points 
     294      END DO 
     295      IF( ANY(lsend1) .OR. ANY(lrecv1) ) THEN   ! if need to send/recv in at least one direction 
     296         CALL lbc_bdy_lnk( 'bdydyn2d', lsend1, lrecv1, zssh(:,:,1), 'T',  1. ) 
     297      END IF 
    269298      ! 
    270299   END SUBROUTINE bdy_ssh 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/BDY/bdydyn3d.F90

    r11049 r11067  
    4343      ! 
    4444      INTEGER ::   ib_bdy   ! loop index 
    45       !!---------------------------------------------------------------------- 
    46       ! 
     45      LOGICAL, DIMENSION(4) :: lsend2, lrecv2, lsend3, lrecv3  ! indicate how communications are to be carried out 
     46 
     47      !!---------------------------------------------------------------------- 
    4748      DO ib_bdy=1, nb_bdy 
    4849         ! 
    … …  
    6061      END DO 
    6162      ! 
     63      lsend2(:) = .false. 
     64      lrecv2(:) = .false. 
     65      lsend3(:) = .false. 
     66      lrecv3(:) = .false. 
     67      DO ib_bdy=1, nb_bdy 
     68         SELECT CASE( cn_dyn3d(ib_bdy) ) 
     69         CASE('orlanski') 
     70            lsend2(:) = lsend2(:) .OR. lsend_bdy(ib_bdy,2,:)   ! to   every bdy neighbour, U points 
     71            lrecv2(:) = lrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:)   ! from every bdy neighbour, U points 
     72            lsend3(:) = lsend3(:) .OR. lsend_bdy(ib_bdy,3,:)   ! to   every bdy neighbour, V points 
     73            lrecv3(:) = lrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:)   ! from every bdy neighbour, V points 
     74         CASE('orlanski_npo') 
     75            lsend2(:) = lsend2(:) .OR. lsend_bdy(ib_bdy,2,:)   ! to   every bdy neighbour, U points 
     76            lrecv2(:) = lrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:)   ! from every bdy neighbour, U points 
     77            lsend3(:) = lsend3(:) .OR. lsend_bdy(ib_bdy,3,:)   ! to   every bdy neighbour, V points 
     78            lrecv3(:) = lrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:)   ! from every bdy neighbour, V points 
     79         CASE('zerograd') 
     80            lsend2(:) = lsend2(:) .OR. lsend_bdy(ib_bdy,2,:)   ! to   every bdy neighbour, U points 
     81            lrecv2(:) = lrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:)   ! from every bdy neighbour, U points 
     82            lsend3(:) = lsend3(:) .OR. lsend_bdy(ib_bdy,3,:)   ! to   every bdy neighbour, V points 
     83            lrecv3(:) = lrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:)   ! from every bdy neighbour, V points 
     84         CASE('neumann') 
     85            lsend2(:) = lsend2(:) .OR. lsend_bdy(ib_bdy,2,:)   ! to   every bdy neighbour, U points 
     86            lrecv2(:) = lrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:)   ! from every bdy neighbour, U points 
     87            lsend3(:) = lsend3(:) .OR. lsend_bdy(ib_bdy,3,:)   ! to   every bdy neighbour, V points 
     88            lrecv3(:) = lrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:)   ! from every bdy neighbour, V points 
     89         END SELECT 
     90      END DO 
     91      ! 
     92      IF( ANY(lsend2) .OR. ANY(lrecv2) ) THEN   ! if need to send/recv in at least one direction 
     93         CALL lbc_bdy_lnk( 'bdydyn2d', lsend2, lrecv2, ua, 'U', -1. ) 
     94      END IF 
     95      IF( ANY(lsend3) .OR. ANY(lrecv3) ) THEN   ! if need to send/recv in at least one direction 
     96         CALL lbc_bdy_lnk( 'bdydyn2d', lsend3, lrecv3, va, 'V', -1. ) 
     97      END IF 
     98      ! 
    6299   END SUBROUTINE bdy_dyn3d 
    63100 
    … …  
    78115      INTEGER  ::   jb, jk         ! dummy loop indices 
    79116      INTEGER  ::   ii, ij, igrd   ! local integers 
    80       REAL(wp) ::   zwgt           ! boundary weight 
    81117      !!---------------------------------------------------------------------- 
    82118      ! 
    … …  
    98134         END DO 
    99135      END DO 
    100       ! 
    101       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
    102       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 
    103136      ! 
    104137   END SUBROUTINE bdy_dyn3d_spe 
    … …  
    156189      END DO 
    157190      ! 
    158       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
    159       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    160       ! 
    161191   END SUBROUTINE bdy_dyn3d_zgrad 
    162192 
    … …  
    176206      INTEGER  ::   ib, ik         ! dummy loop indices 
    177207      INTEGER  ::   ii, ij, igrd   ! local integers 
    178       REAL(wp) ::   zwgt           ! boundary weight 
    179208      !!---------------------------------------------------------------------- 
    180209      ! 
    … …  
    187216         END DO 
    188217      END DO 
    189  
     218      ! 
    190219      igrd = 3                       ! Everything is at T-points here 
    191220      DO ib = 1, idx%nblenrim(igrd) 
    … …  
    196225         END DO 
    197226      END DO 
    198       ! 
    199       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 
    200227      ! 
    201228   END SUBROUTINE bdy_dyn3d_zro 
    … …  
    241268            va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta%v3d(jb,jk) - va(ii,ij,jk) ) ) * vmask(ii,ij,jk) 
    242269         END DO 
    243       END DO  
    244       ! 
    245       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    246       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
     270      END DO    
    247271      ! 
    248272   END SUBROUTINE bdy_dyn3d_frs 
    … …  
    276300      !   
    277301      CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo ) 
    278       ! 
    279       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    280       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    281302      ! 
    282303   END SUBROUTINE bdy_dyn3d_orlanski 
    … …  
    326347      END DO 
    327348      ! 
    328       CALL lbc_lnk_multi( 'bdydyn3d', ua, 'U', -1.,  va, 'V', -1. )   ! Boundary points should be updated 
    329       ! 
    330349      IF( ln_timing )   CALL timing_stop('bdy_dyn3d_dmp') 
    331350      ! 
    … …  
    346365 
    347366      INTEGER  ::   jb, igrd                               ! dummy loop indices 
     367      LOGICAL, DIMENSION(4) :: lsend2, lrecv2, lsend3, lrecv3  ! indicate how communications are to be carried out 
    348368      !!---------------------------------------------------------------------- 
    349369      ! 
    … …  
    358378      CALL bdy_nmn( idx, igrd, va )   ! va is masked 
    359379      ! 
    360       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    361       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 
    362       ! 
    363380   END SUBROUTINE bdy_dyn3d_nmn 
    364381 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/BDY/bdyice.F90

    r11049 r11067  
    5555      INTEGER, INTENT(in) ::   kt   ! Main time step counter 
    5656      ! 
    57       INTEGER ::   jbdy   ! BDY set index 
     57      INTEGER ::   jbdy                               ! BDY set index 
     58      LOGICAL, DIMENSION(4)       :: lsend1, lrecv1   ! indicate how communications are to be carried out 
    5859      !!---------------------------------------------------------------------- 
    5960      ! controls 
    … …  
    7374         ! 
    7475      END DO 
     76      ! 
     77      ! Update bdy points 
     78      lsend1(:) = .false. 
     79      lrecv1(:) = .false. 
     80      DO jbdy = 1, nb_bdy 
     81         IF( cn_ice(jbdy) == 'frs' ) THEN 
     82            lsend1(:) = lsend1(:) .OR. lsend_bdy(jbdy,1,:)   ! to   every neighbour, T points 
     83            lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(jbdy,1,:)   ! from every neighbour, T points 
     84         END IF 
     85      END DO 
     86      IF( ANY(lsend1) .OR. ANY(lrecv1) ) THEN   ! if need to send/recv in at least one direction 
     87         ! exchange 3d arrays 
     88         CALL lbc_bdy_lnk_multi( 'bdyice', lsend1, lrecv1, a_i , 'T', 1., h_i , 'T', 1., h_s , 'T', 1. & 
     89              &                                          , oa_i, 'T', 1., a_ip, 'T', 1., v_ip, 'T', 1. & 
     90              &                                          , s_i , 'T', 1., t_su, 'T', 1., v_i , 'T', 1. & 
     91              &                                          , v_s , 'T', 1., sv_i, 'T', 1.                ) 
     92         ! exchange 4d arrays 
     93         CALL lbc_bdy_lnk_multi( 'bdyice', lsend1, lrecv1, t_s , 'T', 1., e_s , 'T', 1. )   ! third dimension = 1 
     94         CALL lbc_bdy_lnk_multi( 'bdyice', lsend1, lrecv1, t_i , 'T', 1., e_i , 'T', 1. )   ! third dimension = 2 
     95      END IF 
    7596      ! 
    7697      CALL ice_cor( kt , 0 )      ! -- In case categories are out of bounds, do a remapping 
    … …  
    139160         ENDDO 
    140161      ENDDO 
    141       CALL lbc_bdy_lnk( 'bdyice', a_i(:,:,:), 'T', 1., jbdy ) 
    142       CALL lbc_bdy_lnk( 'bdyice', h_i(:,:,:), 'T', 1., jbdy ) 
    143       CALL lbc_bdy_lnk( 'bdyice', h_s(:,:,:), 'T', 1., jbdy ) 
    144162 
    145163      DO jl = 1, jpl 
    … …  
    260278         ! 
    261279      END DO ! jl 
    262  
    263       CALL lbc_bdy_lnk( 'bdyice', a_i (:,:,:)  , 'T', 1., jbdy ) 
    264       CALL lbc_bdy_lnk( 'bdyice', h_i (:,:,:)  , 'T', 1., jbdy ) 
    265       CALL lbc_bdy_lnk( 'bdyice', h_s (:,:,:)  , 'T', 1., jbdy ) 
    266       CALL lbc_bdy_lnk( 'bdyice', oa_i(:,:,:)  , 'T', 1., jbdy ) 
    267       CALL lbc_bdy_lnk( 'bdyice', a_ip(:,:,:)  , 'T', 1., jbdy ) 
    268       CALL lbc_bdy_lnk( 'bdyice', v_ip(:,:,:)  , 'T', 1., jbdy ) 
    269       CALL lbc_bdy_lnk( 'bdyice', s_i (:,:,:)  , 'T', 1., jbdy ) 
    270       CALL lbc_bdy_lnk( 'bdyice', t_su(:,:,:)  , 'T', 1., jbdy ) 
    271       CALL lbc_bdy_lnk( 'bdyice', v_i (:,:,:)  , 'T', 1., jbdy ) 
    272       CALL lbc_bdy_lnk( 'bdyice', v_s (:,:,:)  , 'T', 1., jbdy ) 
    273       CALL lbc_bdy_lnk( 'bdyice', sv_i(:,:,:)  , 'T', 1., jbdy ) 
    274       CALL lbc_bdy_lnk( 'bdyice', t_s (:,:,:,:), 'T', 1., jbdy ) 
    275       CALL lbc_bdy_lnk( 'bdyice', e_s (:,:,:,:), 'T', 1., jbdy ) 
    276       CALL lbc_bdy_lnk( 'bdyice', t_i (:,:,:,:), 'T', 1., jbdy ) 
    277       CALL lbc_bdy_lnk( 'bdyice', e_i (:,:,:,:), 'T', 1., jbdy ) 
    278280      !       
    279281   END SUBROUTINE bdy_ice_frs 
    … …  
    297299      INTEGER  ::   jbdy             ! BDY set index 
    298300      REAL(wp) ::   zmsk1, zmsk2, zflag 
     301      LOGICAL, DIMENSION(4) :: lsend2, lrecv2, lsend3, lrecv3  ! indicate how communications are to be carried out 
    299302      !!------------------------------------------------------------------------------ 
    300303      IF( ln_timing )   CALL timing_start('bdy_ice_dyn') 
    … …  
    339342                  ! 
    340343               END DO 
    341                CALL lbc_bdy_lnk( 'bdyice', u_ice(:,:), 'U', -1., jbdy ) 
    342344               ! 
    343345            CASE ( 'V' ) 
    … …  
    371373                  ! 
    372374               END DO 
    373                CALL lbc_bdy_lnk( 'bdyice', v_ice(:,:), 'V', -1., jbdy ) 
    374375               ! 
    375376            END SELECT 
    … …  
    379380         END SELECT 
    380381         ! 
    381       END DO 
     382      END DO   ! jbdy 
     383      ! 
     384      SELECT CASE ( cd_type )         
     385      CASE ( 'U' )  
     386         lsend2(:) = .false.   ;   lrecv2(:) = .false. 
     387         DO jbdy = 1, nb_bdy 
     388            IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN 
     389               lsend2(:) = lsend2(:) .OR. lsend_bdy(jbdy,2,:)   ! to   every bdy neighbour, U points 
     390               lrecv2(:) = lrecv2(:) .OR. lrecv_bdy(jbdy,2,:)   ! from every bdy neighbour, U points 
     391            END IF 
     392         END DO 
     393         IF( ANY(lsend2) .OR. ANY(lrecv2) ) THEN   ! if need to send/recv in at least one direction 
     394            CALL lbc_bdy_lnk( 'bdyice', lsend2, lrecv2, u_ice, 'U', -1. ) 
     395         END IF 
     396      CASE ( 'V' ) 
     397         lsend3(:) = .false.   ;   lrecv3(:) = .false. 
     398         DO jbdy = 1, nb_bdy 
     399            IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN 
     400               lsend3(:) = lsend3(:) .OR. lsend_bdy(jbdy,3,:)   ! to   every bdy neighbour, V points 
     401               lrecv3(:) = lrecv3(:) .OR. lrecv_bdy(jbdy,3,:)   ! from every bdy neighbour, V points 
     402            END IF 
     403         END DO 
     404         IF( ANY(lsend3) .OR. ANY(lrecv3) ) THEN   ! if need to send/recv in at least one direction 
     405            CALL lbc_bdy_lnk( 'bdyice', lsend3, lrecv3, v_ice, 'V', -1. ) 
     406         END IF 
     407      END SELECT 
    382408      ! 
    383409      IF( ln_timing )   CALL timing_stop('bdy_ice_dyn') 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/BDY/bdyini.F90

    r11059 r11067  
    3737   INTEGER, PARAMETER ::   jp_nseg = 100   !  
    3838   INTEGER, PARAMETER ::   nrimmax =  20   ! maximum rimwidth in structured 
    39    INTEGER  :: nde = 1 ! domain extended in the halo to deal with bondaries  
    4039                                               ! open boundary data files 
    4140   ! Straight open boundary segment parameters: 
    … …  
    11771176      END DO 
    11781177 
     1178 
     1179      ALLOCATE( lsend_bdy(nb_bdy,jpbgrd,4), lrecv_bdy(nb_bdy,jpbgrd,4) ) 
     1180      lsend_bdy(:,:,:) = .false. 
     1181      lrecv_bdy(:,:,:) = .false.  
     1182      ! 
     1183      ! Check which boundaries might need communication 
     1184      DO igrd = 1, jpbgrd 
     1185         DO ib_bdy = 1, nb_bdy 
     1186            IF     ( nbondi_bdy  (ib_bdy) ==  0 )   THEN  
     1187               lsend_bdy(ib_bdy,igrd,1) = .true. 
     1188               lsend_bdy(ib_bdy,igrd,2) = .true. 
     1189            ELSE IF( nbondi_bdy  (ib_bdy) ==  1 )   THEN 
     1190               lsend_bdy(ib_bdy,igrd,1) = .true. 
     1191            ELSE IF( nbondi_bdy  (ib_bdy) == -1 )   THEN 
     1192               lsend_bdy(ib_bdy,igrd,2) = .true. 
     1193            END IF 
     1194            IF     ( nbondi_bdy_b(ib_bdy) ==  0 )   THEN  
     1195               lrecv_bdy(ib_bdy,igrd,1) = .true. 
     1196               lrecv_bdy(ib_bdy,igrd,2) = .true. 
     1197            ELSE IF( nbondi_bdy_b(ib_bdy) ==  1 )   THEN 
     1198               lrecv_bdy(ib_bdy,igrd,1) = .true. 
     1199            ELSE IF( nbondi_bdy_b(ib_bdy) == -1 )   THEN 
     1200               lrecv_bdy(ib_bdy,igrd,2) = .true. 
     1201            END IF 
     1202            IF(      nbondj_bdy  (ib_bdy) ==  0 )   THEN  
     1203               lsend_bdy(ib_bdy,igrd,3) = .true. 
     1204               lsend_bdy(ib_bdy,igrd,4) = .true. 
     1205            ELSE IF( nbondj_bdy  (ib_bdy) ==  1 )   THEN 
     1206               lsend_bdy(ib_bdy,igrd,3) = .true. 
     1207            ELSE IF( nbondj_bdy  (ib_bdy) == -1 )   THEN 
     1208               lsend_bdy(ib_bdy,igrd,4) = .true. 
     1209            END IF 
     1210            IF(      nbondj_bdy_b(ib_bdy) ==  0 )   THEN  
     1211               lrecv_bdy(ib_bdy,igrd,3) = .true. 
     1212               lrecv_bdy(ib_bdy,igrd,4) = .true. 
     1213            ELSE IF( nbondj_bdy_b(ib_bdy) ==  1 )   THEN 
     1214               lrecv_bdy(ib_bdy,igrd,3) = .true. 
     1215            ELSE IF( nbondj_bdy_b(ib_bdy) == -1 )   THEN 
     1216               lrecv_bdy(ib_bdy,igrd,4) = .true. 
     1217            END IF 
     1218         END DO 
     1219      END DO 
    11791220      ! 
    11801221      ! Tidy up 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/BDY/bdytra.F90

    r11049 r11067  
    5151      INTEGER                        :: ib_bdy, jn, igrd   ! Loop indeces 
    5252      TYPE(ztrabdy), DIMENSION(jpts) :: zdta               ! Temporary data structure 
     53      LOGICAL, DIMENSION(4)          :: lsend1, lrecv1     ! indicate how communications are to be carried out 
    5354      !!---------------------------------------------------------------------- 
    5455      igrd = 1  
    … …  
    7172            CASE DEFAULT           ;   CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 
    7273            END SELECT 
    73             ! Boundary points should be updated 
    74             CALL lbc_bdy_lnk( 'bdytra', tsa(:,:,:,jn), 'T', 1., ib_bdy ) 
    7574            !  
    7675         END DO 
    7776      END DO 
     77      ! 
     78      lsend1(:) = .false. 
     79      lrecv1(:) = .false. 
     80      DO ib_bdy=1, nb_bdy 
     81         SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
     82         CASE('neumann') 
     83            lsend1(:) = lsend1(:) .OR. lsend_bdy(ib_bdy,1,:)   ! to   every bdy neighbour, T points 
     84            lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:)   ! from every bdy neighbour, T points 
     85         CASE('orlanski') 
     86            lsend1(:) = lsend1(:) .OR. lsend_bdy(ib_bdy,1,:)   ! to   every bdy neighbour, T points 
     87            lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:)   ! from every bdy neighbour, T points 
     88         CASE('orlanski_npo') 
     89            lsend1(:) = lsend1(:) .OR. lsend_bdy(ib_bdy,1,:)   ! to   every bdy neighbour, T points 
     90            lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:)   ! from every bdy neighbour, T points 
     91         CASE('runoff') 
     92            lsend1(:) = lsend1(:) .OR. lsend_bdy(ib_bdy,1,:)   ! to   every bdy neighbour, T points 
     93            lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:)   ! from every bdy neighbour, T points 
     94         END SELECT 
     95      END DO 
     96      IF( ANY(lsend1) .OR. ANY(lrecv1) ) THEN   ! if need to send/recv in at least one direction 
     97         CALL lbc_bdy_lnk( 'bdytra', lsend1, lrecv1, tsa, 'T',  1. ) 
     98      END IF 
    7899      ! 
    79100   END SUBROUTINE bdy_tra 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/DYN/dynkeg.F90

    r11049 r11067  
    8080      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv  
    8181      REAL(wp)  :: zweightu, zweightv 
     82      LOGICAL, DIMENSION(4) :: lsend1, lrecv1  ! indicate how bdy communications are to be carried out 
    8283      !!---------------------------------------------------------------------- 
    8384      ! 
    … …  
    134135                  END DO 
    135136               END IF 
    136                CALL lbc_bdy_lnk( 'dynkeg', zhke, 'T', 1., ib_bdy )   ! send 2 and recv jpi, jpj used in the computation of the speed tendencies 
    137             END DO 
     137            END DO 
     138            ! send 2 and recv jpi, jpj used in the computation of the speed tendencies 
     139            lsend1(:) = .false. 
     140            lrecv1(:) = .false. 
     141            DO ib_bdy = 1, nb_bdy 
     142               lsend1(:) = lsend1(:) .OR. lsend_bdy(ib_bdy,1,:)   ! to   every bdy neighbour, T points 
     143               lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:)   ! from every bdy neighbour, T points 
     144            END DO 
     145            IF( COUNT(lsend1) > 0 .OR. COUNT(lrecv1) > 0 ) THEN   ! if need to send/recv in at least one direction 
     146               CALL lbc_bdy_lnk( 'bdydyn2d', lsend1, lrecv1, zhke, 'T',  1. ) 
     147            END IF 
    138148         END IF 
    139149         ! 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r10425 r11067  
    1414#   define PTR_ptab              pt4d 
    1515#endif 
    16    SUBROUTINE ROUTINE_MULTI( cdname                                                    & 
    17       &                    , pt1, cdna1, psgn1, pt2, cdna2, psgn2, pt3, cdna3, psgn3   & 
    18       &                    , pt4, cdna4, psgn4, pt5, cdna5, psgn5, pt6, cdna6, psgn6   & 
    19       &                    , pt7, cdna7, psgn7, pt8, cdna8, psgn8, pt9, cdna9, psgn9, cd_mpp, pval) 
     16 
     17#if defined IS_BDY 
     18   SUBROUTINE ROUTINE_MULTI( cdname, lsend, lrecv                                                               & 
     19      &                    , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4   & 
     20      &                    , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8   & 
     21      &                    , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11                      & 
     22      &                    , cd_mpp, pval ) 
     23      LOGICAL, DIMENSION(4)        , INTENT(in   ) ::   lsend, lrecv   ! indicate how communications are to be carried out 
     24#else 
     25   SUBROUTINE ROUTINE_MULTI( cdname                                                                             & 
     26      &                    , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4   & 
     27      &                    , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8   & 
     28      &                    , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11                      & 
     29      &                    , cd_mpp, pval ) 
     30#endif 
    2031      !!--------------------------------------------------------------------- 
    21       CHARACTER(len=*)   ,                   INTENT(in   ) ::   cdname  ! name of the calling subroutine 
    22       ARRAY_TYPE(:,:,:,:)          , TARGET, INTENT(inout) ::   pt1     ! arrays on which the lbc is applied 
    23       ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) ::   pt2  ,  pt3  , pt4  , pt5  , pt6  , pt7  , pt8  , pt9 
    24       CHARACTER(len=1)                     , INTENT(in   ) ::   cdna1   ! nature of pt2D. array grid-points 
    25       CHARACTER(len=1)   , OPTIONAL        , INTENT(in   ) ::   cdna2,  cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9 
    26       REAL(wp)                             , INTENT(in   ) ::   psgn1   ! sign used across the north fold 
    27       REAL(wp)           , OPTIONAL        , INTENT(in   ) ::   psgn2,  psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9    
    28       CHARACTER(len=3)   , OPTIONAL        , INTENT(in   ) ::   cd_mpp  ! fill the overlap area only 
    29       REAL(wp)           , OPTIONAL        , INTENT(in   ) ::   pval    ! background value (used at closed boundaries) 
     32      CHARACTER(len=*)   ,                   INTENT(in   ) ::  cdname  ! name of the calling subroutine 
     33      ARRAY_TYPE(:,:,:,:)          , TARGET, INTENT(inout) ::  pt1     ! arrays on which the lbc is applied 
     34      ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) ::  pt2  , pt3  , pt4  , pt5  , pt6  , pt7  , pt8  , pt9  , pt10  , pt11 
     35      CHARACTER(len=1)                     , INTENT(in   ) ::  cdna1   ! nature of pt2D. array grid-points 
     36      CHARACTER(len=1)   , OPTIONAL        , INTENT(in   ) ::  cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 
     37      REAL(wp)                             , INTENT(in   ) ::  psgn1   ! sign used across the north fold 
     38      REAL(wp)           , OPTIONAL        , INTENT(in   ) ::  psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 
     39      CHARACTER(len=3)   , OPTIONAL        , INTENT(in   ) ::  cd_mpp  ! fill the overlap area only 
     40      REAL(wp)           , OPTIONAL        , INTENT(in   ) ::  pval    ! background value (used at closed boundaries) 
    3041      !! 
    31       INTEGER                         ::   kfld        ! number of elements that will be attributed 
    32       PTR_TYPE         , DIMENSION(9) ::   ptab_ptr    ! pointer array 
    33       CHARACTER(len=1) , DIMENSION(9) ::   cdna_ptr    ! nature of ptab_ptr grid-points 
    34       REAL(wp)         , DIMENSION(9) ::   psgn_ptr    ! sign used across the north fold boundary 
     42      INTEGER                          ::   kfld        ! number of elements that will be attributed 
     43      PTR_TYPE         , DIMENSION(11) ::   ptab_ptr    ! pointer array 
     44      CHARACTER(len=1) , DIMENSION(11) ::   cdna_ptr    ! nature of ptab_ptr grid-points 
     45      REAL(wp)         , DIMENSION(11) ::   psgn_ptr    ! sign used across the north fold boundary 
    3546      !!--------------------------------------------------------------------- 
    3647      ! 
    … …  
    4152      ! 
    4253      !                 ! Look if more arrays are added 
    43       IF( PRESENT(psgn2) )   CALL ROUTINE_LOAD( pt2, cdna2, psgn2, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    44       IF( PRESENT(psgn3) )   CALL ROUTINE_LOAD( pt3, cdna3, psgn3, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    45       IF( PRESENT(psgn4) )   CALL ROUTINE_LOAD( pt4, cdna4, psgn4, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    46       IF( PRESENT(psgn5) )   CALL ROUTINE_LOAD( pt5, cdna5, psgn5, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    47       IF( PRESENT(psgn6) )   CALL ROUTINE_LOAD( pt6, cdna6, psgn6, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    48       IF( PRESENT(psgn7) )   CALL ROUTINE_LOAD( pt7, cdna7, psgn7, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    49       IF( PRESENT(psgn8) )   CALL ROUTINE_LOAD( pt8, cdna8, psgn8, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    50       IF( PRESENT(psgn9) )   CALL ROUTINE_LOAD( pt9, cdna9, psgn9, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     54      IF( PRESENT(psgn2 ) )   CALL ROUTINE_LOAD( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     55      IF( PRESENT(psgn3 ) )   CALL ROUTINE_LOAD( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     56      IF( PRESENT(psgn4 ) )   CALL ROUTINE_LOAD( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     57      IF( PRESENT(psgn5 ) )   CALL ROUTINE_LOAD( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     58      IF( PRESENT(psgn6 ) )   CALL ROUTINE_LOAD( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     59      IF( PRESENT(psgn7 ) )   CALL ROUTINE_LOAD( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     60      IF( PRESENT(psgn8 ) )   CALL ROUTINE_LOAD( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     61      IF( PRESENT(psgn9 ) )   CALL ROUTINE_LOAD( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     62      IF( PRESENT(psgn10) )   CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     63      IF( PRESENT(psgn11) )   CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    5164      ! 
    52       CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, cd_mpp, pval ) 
     65#if defined IS_BDY 
     66      CALL lbc_bdy_lnk_ptr( cdname, lsend, lrecv, ptab_ptr, cdna_ptr, psgn_ptr, kfld               ) 
     67#else  
     68      CALL lbc_lnk_ptr    ( cdname,               ptab_ptr, cdna_ptr, psgn_ptr, kfld, cd_mpp, pval ) 
     69#endif 
    5370      ! 
    5471   END SUBROUTINE ROUTINE_MULTI 
    … …  
    7289      ! 
    7390   END SUBROUTINE ROUTINE_LOAD 
     91 
    7492#undef ARRAY_TYPE 
    7593#undef PTR_TYPE 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/lbclnk.F90

    r10425 r11067  
    3838   ! 
    3939   INTERFACE lbc_bdy_lnk 
    40       MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 
     40      MODULE PROCEDURE   mpp_lnk_bdy_2d      , mpp_lnk_bdy_3d      , mpp_lnk_bdy_4d 
     41   END INTERFACE 
     42   INTERFACE lbc_bdy_lnk_ptr 
     43      MODULE PROCEDURE   mpp_lnk_bdy_2d_ptr  , mpp_lnk_bdy_3d_ptr  , mpp_lnk_bdy_4d_ptr 
     44   END INTERFACE 
     45   INTERFACE lbc_bdy_lnk_multi 
     46      MODULE PROCEDURE   lbc_lnk_bdy_2d_multi, lbc_lnk_bdy_3d_multi, lbc_lnk_bdy_4d_multi 
    4147   END INTERFACE 
    4248   ! 
    … …  
    4551   END INTERFACE 
    4652 
    47    PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
    48    PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    49    PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    50    PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
     53   PUBLIC   lbc_lnk           ! ocean/ice lateral boundary conditions 
     54   PUBLIC   lbc_lnk_multi     ! modified ocean/ice lateral boundary conditions 
     55   PUBLIC   lbc_bdy_lnk       ! ocean lateral BDY boundary conditions 
     56   PUBLIC   lbc_bdy_lnk_multi ! modified ocean lateral BDY boundary conditions 
     57   PUBLIC   lbc_lnk_icb       ! iceberg lateral boundary conditions 
    5158 
    5259   !!---------------------------------------------------------------------- 
    … …  
    256263 
    257264#  define DIM_2d 
     265#     define ROUTINE_LOAD           load_ptr_2d 
    258266#     define ROUTINE_MULTI          lbc_lnk_2d_multi 
    259 #     define ROUTINE_LOAD           load_ptr_2d 
    260 #     include "lbc_lnk_multi_generic.h90" 
    261 #     undef ROUTINE_MULTI 
     267#     include "lbc_lnk_multi_generic.h90" 
     268#     undef ROUTINE_MULTI 
     269#     undef ROUTINE_LOAD 
     270#     define IS_BDY 
     271#     define ROUTINE_LOAD           load_ptr_bdy_2d 
     272#     define ROUTINE_MULTI          lbc_lnk_bdy_2d_multi 
     273#     include "lbc_lnk_multi_generic.h90" 
     274#     undef ROUTINE_MULTI 
     275#     undef IS_BDY 
    262276#     undef ROUTINE_LOAD 
    263277#  undef DIM_2d 
    264278 
    265  
    266279#  define DIM_3d 
     280#     define ROUTINE_LOAD           load_ptr_3d 
    267281#     define ROUTINE_MULTI          lbc_lnk_3d_multi 
    268 #     define ROUTINE_LOAD           load_ptr_3d 
    269 #     include "lbc_lnk_multi_generic.h90" 
    270 #     undef ROUTINE_MULTI 
     282#     include "lbc_lnk_multi_generic.h90" 
     283#     undef ROUTINE_MULTI 
     284#     undef ROUTINE_LOAD 
     285#     define IS_BDY 
     286#     define ROUTINE_LOAD           load_ptr_bdy_3d 
     287#     define ROUTINE_MULTI          lbc_lnk_bdy_3d_multi 
     288#     include "lbc_lnk_multi_generic.h90" 
     289#     undef ROUTINE_MULTI 
     290#     undef IS_BDY 
    271291#     undef ROUTINE_LOAD 
    272292#  undef DIM_3d 
    273293 
    274  
    275294#  define DIM_4d 
     295#     define ROUTINE_LOAD           load_ptr_4d 
    276296#     define ROUTINE_MULTI          lbc_lnk_4d_multi 
    277 #     define ROUTINE_LOAD           load_ptr_4d 
    278 #     include "lbc_lnk_multi_generic.h90" 
    279 #     undef ROUTINE_MULTI 
     297#     include "lbc_lnk_multi_generic.h90" 
     298#     undef ROUTINE_MULTI 
     299#     undef ROUTINE_LOAD 
     300#     define IS_BDY 
     301#     define ROUTINE_LOAD           load_ptr_bdy_4d 
     302#     define ROUTINE_MULTI          lbc_lnk_bdy_4d_multi 
     303#     include "lbc_lnk_multi_generic.h90" 
     304#     undef ROUTINE_MULTI 
     305#     undef IS_BDY 
    280306#     undef ROUTINE_LOAD 
    281307#  undef DIM_4d 
    282308 
     309 
    283310   !!====================================================================== 
    284311END MODULE lbclnk 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/lib_mpp.F90

    r10982 r11067  
    6969 
    7070   ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 
    71    PUBLIC   mpp_lnk_2d    , mpp_lnk_3d    , mpp_lnk_4d 
    72    PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 
     71   PUBLIC   mpp_lnk_2d        , mpp_lnk_3d        , mpp_lnk_4d 
     72   PUBLIC   mpp_lnk_2d_ptr    , mpp_lnk_3d_ptr    , mpp_lnk_4d_ptr 
     73   PUBLIC   mpp_lnk_bdy_2d    , mpp_lnk_bdy_3d    , mpp_lnk_bdy_4d 
     74   PUBLIC   mpp_lnk_bdy_2d_ptr, mpp_lnk_bdy_3d_ptr, mpp_lnk_bdy_4d_ptr 
    7375   ! 
    7476!!gm  this should be useless 
    … …  
    8789   PUBLIC   mpp_ini_znl 
    8890   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    89    PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 
    9091    
    9192   !! * Interfaces 
    … …  
    451452#     include "mpp_bdy_generic.h90" 
    452453#     undef ROUTINE_BDY 
     454#     define MULTI 
     455#     define ROUTINE_BDY           mpp_lnk_bdy_2d_ptr 
     456#     include "mpp_bdy_generic.h90" 
     457#     undef ROUTINE_BDY 
     458#     undef MULTI 
    453459#  undef DIM_2d 
    454460   ! 
    … …  
    459465#     include "mpp_bdy_generic.h90" 
    460466#     undef ROUTINE_BDY 
     467#     define MULTI 
     468#     define ROUTINE_BDY           mpp_lnk_bdy_3d_ptr 
     469#     include "mpp_bdy_generic.h90" 
     470#     undef ROUTINE_BDY 
     471#     undef MULTI 
    461472#  undef DIM_3d 
    462473   ! 
    … …  
    467478#     include "mpp_bdy_generic.h90" 
    468479#     undef ROUTINE_BDY 
     480#     define MULTI 
     481#     define ROUTINE_BDY           mpp_lnk_bdy_4d_ptr 
     482#     include "mpp_bdy_generic.h90" 
     483#     undef ROUTINE_BDY 
     484#     undef MULTI 
    469485#  undef DIM_4d 
    470486 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/mpp_bdy_generic.h90

    r10629 r11067  
     1#if defined MULTI 
     2#   define NAT_IN(k)                cd_nat(k)    
     3#   define SGN_IN(k)                psgn(k) 
     4#   define F_SIZE(ptab)             kfld 
     5#   define OPT_K(k)                 ,ipf 
     6#   if defined DIM_2d 
     7#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)                , INTENT(inout) ::   ptab(f) 
     8#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
     9#      define K_SIZE(ptab)             1 
     10#      define L_SIZE(ptab)             1 
     11#   endif 
     12#   if defined DIM_3d 
     13#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)                , INTENT(inout) ::   ptab(f) 
     14#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
     15#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
     16#      define L_SIZE(ptab)             1 
     17#   endif 
     18#   if defined DIM_4d 
     19#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)                , INTENT(inout) ::   ptab(f) 
     20#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
     21#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
     22#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4) 
     23#   endif 
     24#else 
    125#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
    226#   define NAT_IN(k)                cd_nat 
    327#   define SGN_IN(k)                psgn 
    4 #   define IBD_IN(k)                kb_bdy 
    528#   define F_SIZE(ptab)             1 
    629#   define OPT_K(k)                  
    … …  
    2043#      define L_SIZE(ptab)          SIZE(ptab,4) 
    2144#   endif 
    22  
    23    SUBROUTINE ROUTINE_BDY( cdname, ptab, cd_nat, psgn      , kb_bdy ) 
     45#endif 
    2446      !!---------------------------------------------------------------------- 
    25       !!                  ***  routine mpp_lnk_bdy_3d  *** 
     47      !!                  ***  routine mpp_lnk_bdy  *** 
    2648      !! 
    2749      !! ** Purpose :   Message passing management 
    … …  
    3254      !!                    nlci   : first dimension of the local subdomain 
    3355      !!                    nlcj   : second dimension of the local subdomain 
    34       !!                    nbondi_bdy : mark for "east-west local boundary" 
    35       !!                    nbondj_bdy : mark for "north-south local boundary" 
    3656      !!                    noea   : number for local neighboring processors  
    3757      !!                    nowe   : number for local neighboring processors 
    … …  
    4262      !! 
    4363      !!---------------------------------------------------------------------- 
    44       CHARACTER(len=*)            , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
     64#if defined MULTI 
     65   SUBROUTINE ROUTINE_BDY( cdname, lsend, lrecv, ptab, cd_nat, psgn, kfld ) 
     66      INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
     67#else 
     68   SUBROUTINE ROUTINE_BDY( cdname, lsend, lrecv, ptab, cd_nat, psgn       ) 
     69#endif 
     70      CHARACTER(len=*)            , INTENT(in   ) ::   cdname        ! name of the calling subroutine 
    4571      ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied 
    46       CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    47       REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
    48       INTEGER                     , INTENT(in   ) ::   IBD_IN(:)   ! BDY boundary set 
     72      CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)     ! nature of array grid-points 
     73      REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)     ! sign used across the north fold boundary 
     74      LOGICAL, DIMENSION(4)       , INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc 
    4975      ! 
    5076      INTEGER  ::   ji, jj, jk, jl, jh, jf     ! dummy loop indices 
    … …  
    5278      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    5379      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    54       REAL(wp) ::   zland                      ! local scalar 
    5580      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    56       ! 
    57       REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    58       REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
     81      LOGICAL  ::   llsend_we, llsend_ea, llsend_no, llsend_so       ! communication send 
     82      LOGICAL  ::   llrecv_we, llrecv_ea, llrecv_no, llrecv_so       ! communication receive  
     83      ! 
     84      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsend_no, zsend_so   ! 3d for north-south & south-north send 
     85      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsend_ea, zsend_we   ! 3d for east-west   & west-east   send 
     86      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zrecv_no, zrecv_so   ! 3d for north-south & south-north receive 
     87      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zrecv_ea, zrecv_we   ! 3d for east-west   & west-east   receive 
    5988      !!---------------------------------------------------------------------- 
    6089      ! 
    … …  
    6291      ipl = L_SIZE(ptab)   ! 4th    - 
    6392      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
     93      llsend_we = lsend(1);  llsend_ea = lsend(2);  llsend_so = lsend(3);  llsend_no = lsend(4); 
     94      llrecv_we = lrecv(1);  llrecv_ea = lrecv(2);  llrecv_so = lrecv(3);  llrecv_no = lrecv(4); 
    6495      ! 
    6596      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 
    66       !       
    67       ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   & 
    68          &      zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2)  ) 
    69  
    70       zland = 0._wp 
     97 
    7198 
    7299      ! 1. standard boundary treatment 
    73100      ! ------------------------------ 
    74       ! 
     101      ! Bdy treatment does not update land points 
    75102      DO jf = 1, ipf                   ! number of arrays to be treated 
    76          ! 
    77          !                                ! East-West boundaries 
    78          !                     
    79          IF( nbondi == 2) THEN                  ! neither subdomain to the east nor to the west 
    80             !                                      !* Cyclic 
     103         IF( nbondi == 2 ) THEN                  ! neither subdomain to the east nor to the west 
     104            !                                      !* Cyclic East-West boundaries 
    81105            IF( l_Iperio ) THEN 
    82106               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf) 
    83107               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf) 
    84             ELSE                                   !* Closed 
    85                IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland  ! east except F-point 
    86                                                ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland  ! west 
    87             ENDIF 
    88          ELSEIF(nbondi == -1) THEN              ! subdomain to the east only 
    89             IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(1:nn_hls,:,:,:,jf) = zland     ! south except F-point 
    90             ! 
    91          ELSEIF(nbondi ==  1) THEN              ! subdomain to the west only 
    92             ARRAY_IN(nlci-nn_hls+1:jpi,:,:,:,jf) = zland    ! north 
    93          ENDIF 
    94          !                                ! North-South boundaries 
    95          ! 
     108            END IF 
     109         END IF 
    96110         IF( nbondj == 2) THEN                  ! neither subdomain to the north nor to the south 
    97             !                                      !* Cyclic 
     111            !                                      !* Cyclic North-South boundaries 
    98112            IF( l_Jperio ) THEN 
    99113               ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:,jpjm1,:,:,jf) 
    100114               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,  2  ,:,:,jf) 
    101             ELSE                                   !* Closed 
    102                IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :nn_hls,:,:,jf) = zland  ! east except F-point 
    103                                                ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland  ! west 
    104             ENDIF 
    105          ELSEIF(nbondj == -1) THEN              ! subdomain to the east only 
    106             IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,1:nn_hls,:,:,jf) = zland     ! south except F-point 
    107             ! 
    108          ELSEIF(nbondj ==  1) THEN              ! subdomain to the west only 
    109             ARRAY_IN(:,nlcj-nn_hls+1:jpj,:,:,jf) = zland    ! north 
    110          ENDIF 
    111          ! 
     115            END IF 
     116         END IF 
    112117      END DO 
     118 
    113119 
    114120      ! 2. East and west directions exchange 
    … …  
    116122      ! we play with the neigbours AND the row number because of the periodicity  
    117123      ! 
    118       ! 
    119       DO jf = 1, ipf 
    120          SELECT CASE ( nbondi_bdy(IBD_IN(jf)) )      ! Read Dirichlet lateral conditions 
    121          CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    122             iihom = nlci-nreci 
    123                DO jl = 1, ipl 
    124                   DO jk = 1, ipk 
    125                      DO jh = 1, nn_hls 
    126                         zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 
    127                         zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 
    128                      END DO 
    129                   END DO 
    130                END DO 
    131          END SELECT 
    132          ! 
    133          !                           ! Migrations 
    134 !!gm      imigr = nn_hls * jpj * ipk * ipl * ipf 
    135          imigr = nn_hls * jpj * ipk * ipl 
    136          ! 
    137          IF( ln_timing ) CALL tic_tac(.TRUE.) 
    138          ! 
    139          SELECT CASE ( nbondi_bdy(IBD_IN(jf)) ) 
    140          CASE ( -1 ) 
    141             CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 ) 
    142          CASE ( 0 ) 
    143             CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 
    144             CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 ) 
    145          CASE ( 1 ) 
    146             CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 
    147          END SELECT 
    148          ! 
    149          SELECT CASE ( nbondi_bdy_b(IBD_IN(jf)) ) 
    150          CASE ( -1 ) 
    151             CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea ) 
    152          CASE ( 0 ) 
    153             CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea ) 
    154             CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe ) 
    155          CASE ( 1 ) 
    156             CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe ) 
    157          END SELECT 
    158          ! 
    159          SELECT CASE ( nbondi_bdy(IBD_IN(jf)) ) 
    160          CASE ( -1 ) 
    161             IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    162          CASE ( 0 ) 
    163             IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    164             IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    165          CASE ( 1 ) 
    166             IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    167          END SELECT 
    168          ! 
    169          IF( ln_timing ) CALL tic_tac(.FALSE.) 
    170          ! 
    171          !                           ! Write Dirichlet lateral conditions 
     124      IF( llsend_we )   ALLOCATE( zsend_we(jpj,nn_hls,ipk,ipl,ipf) ) 
     125      IF( llsend_ea )   ALLOCATE( zsend_ea(jpj,nn_hls,ipk,ipl,ipf) ) 
     126      IF( llrecv_we )   ALLOCATE( zrecv_we(jpj,nn_hls,ipk,ipl,ipf) ) 
     127      IF( llrecv_ea )   ALLOCATE( zrecv_ea(jpj,nn_hls,ipk,ipl,ipf) ) 
     128      ! 
     129      ! Load arrays to the east and to the west to be sent 
     130      IF( llsend_we )   THEN   ! Read Dirichlet lateral conditions 
     131         DO jf = 1, ipf 
     132            DO jl = 1, ipl 
     133               DO jk = 1, ipk 
     134                  DO jh = 1, nn_hls 
     135                     zsend_we(:,jh,jk,jl,jf) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 
     136                  END DO 
     137               END DO 
     138            END DO 
     139         END DO 
     140      END IF 
     141      ! 
     142      IF( llsend_ea )   THEN   ! Read Dirichlet lateral conditions 
     143         iihom = nlci-nreci 
     144         DO jf = 1, ipf 
     145            DO jl = 1, ipl 
     146               DO jk = 1, ipk 
     147                  DO jh = 1, nn_hls 
     148                     zsend_ea(:,jh,jk,jl,jf) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 
     149                  END DO 
     150               END DO 
     151            END DO 
     152         END DO 
     153      END IF 
     154      ! 
     155      ! Send/receive arrays to the east and to the west                             
     156      imigr = nn_hls * jpj * ipk * ipl * ipf   ! Migrations 
     157      ! 
     158      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     159      ! 
     160      IF( llsend_ea )   CALL mppsend( 2, zsend_ea(1,1,1,1,1), imigr, noea, ml_req1 ) 
     161      IF( llsend_we )   CALL mppsend( 1, zsend_we(1,1,1,1,1), imigr, nowe, ml_req2 ) 
     162      ! 
     163      IF( llrecv_ea )   CALL mpprecv( 1, zrecv_ea(1,1,1,1,1), imigr, noea ) 
     164      IF( llrecv_we )   CALL mpprecv( 2, zrecv_we(1,1,1,1,1), imigr, nowe ) 
     165      ! 
     166      IF( l_isend .AND. llsend_ea ) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     167      IF( l_isend .AND. llsend_we ) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     168      ! 
     169      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     170      ! 
     171      !                           ! Write Dirichlet lateral conditions 
     172      ! Update with the received arrays  
     173      IF( llrecv_we )   THEN 
     174         DO jf = 1, ipf 
     175            DO jl = 1, ipl 
     176               DO jk = 1, ipk 
     177                  DO jh = 1, nn_hls 
     178                     ARRAY_IN(      jh,:,jk,jl,jf) = zrecv_we(:,jh,jk,jl,jf) 
     179                  END DO 
     180               END DO 
     181            END DO 
     182         END DO 
     183      END IF 
     184      ! 
     185      IF( llrecv_ea )   THEN 
    172186         iihom = nlci-nn_hls 
    173          ! 
    174          ! 
    175          SELECT CASE ( nbondi_bdy_b(IBD_IN(jf)) ) 
    176          CASE ( -1 ) 
    177             DO jl = 1, ipl 
    178                DO jk = 1, ipk 
    179                   DO jh = 1, nn_hls 
    180                      ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2) 
    181                   END DO 
    182                END DO 
    183             END DO 
    184          CASE ( 0 ) 
    185             DO jl = 1, ipl 
    186                DO jk = 1, ipk 
    187                   DO jh = 1, nn_hls 
    188                      ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2) 
    189                      ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2) 
    190                   END DO 
    191                END DO 
    192             END DO 
    193          CASE ( 1 ) 
    194             DO jl = 1, ipl 
    195                DO jk = 1, ipk 
    196                   DO jh = 1, nn_hls 
    197                      ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2) 
    198                   END DO 
    199                END DO 
    200             END DO 
    201          END SELECT 
    202          ! 
    203       END DO 
     187         DO jf = 1, ipf 
     188            DO jl = 1, ipl 
     189               DO jk = 1, ipk 
     190                  DO jh = 1, nn_hls 
     191                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zrecv_ea(:,jh,jk,jl,jf) 
     192                  END DO 
     193               END DO 
     194            END DO 
     195         END DO 
     196      END IF 
     197      ! 
     198      ! Clean up 
     199      IF( llsend_we )   DEALLOCATE( zsend_we ) 
     200      IF( llsend_ea )   DEALLOCATE( zsend_ea ) 
     201      IF( llrecv_we )   DEALLOCATE( zrecv_we ) 
     202      IF( llrecv_ea )   DEALLOCATE( zrecv_ea ) 
    204203 
    205204      ! 3. north fold treatment 
    … …  
    220219      ! always closed : we play only with the neigbours 
    221220      ! 
    222       DO jf = 1, ipf 
    223          IF( nbondj_bdy(IBD_IN(jf)) /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    224             ijhom = nlcj-nrecj 
    225             DO jl = 1, ipl 
    226                DO jk = 1, ipk 
    227                   DO jh = 1, nn_hls 
    228                      zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 
    229                      zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 
    230                   END DO 
    231                END DO 
    232             END DO 
    233          ENDIF 
    234          ! 
    235          !                           ! Migrations 
    236 !!gm      imigr = nn_hls * jpi * ipk * ipl * ipf 
    237          imigr = nn_hls * jpi * ipk * ipl 
    238          ! 
    239          IF( ln_timing ) CALL tic_tac(.TRUE.) 
    240          !  
    241          SELECT CASE ( nbondj_bdy(IBD_IN(jf)) ) 
    242          CASE ( -1 ) 
    243             CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 ) 
    244          CASE ( 0 ) 
    245             CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 
    246             CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 ) 
    247          CASE ( 1 ) 
    248             CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 
    249          END SELECT 
    250          !  
    251          SELECT CASE ( nbondj_bdy_b(IBD_IN(jf)) ) 
    252          CASE ( -1 ) 
    253             CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono ) 
    254          CASE ( 0 ) 
    255             CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono ) 
    256             CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso ) 
    257          CASE ( 1 ) 
    258             CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso ) 
    259          END SELECT 
    260          !  
    261          SELECT CASE ( nbondj_bdy(IBD_IN(jf)) ) 
    262          CASE ( -1 ) 
    263             IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    264          CASE ( 0 ) 
    265             IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    266             IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    267          CASE ( 1 ) 
    268             IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    269          END SELECT 
    270          ! 
    271          IF( ln_timing ) CALL tic_tac(.FALSE.) 
    272          ! 
    273          !                           ! Write Dirichlet lateral conditions 
     221      IF( llsend_so )   ALLOCATE( zsend_so(jpi,nn_hls,ipk,ipl,ipf) ) 
     222      IF( llsend_no )   ALLOCATE( zsend_no(jpi,nn_hls,ipk,ipl,ipf) ) 
     223      IF( llrecv_so )   ALLOCATE( zrecv_so(jpi,nn_hls,ipk,ipl,ipf) ) 
     224      IF( llrecv_no )   ALLOCATE( zrecv_no(jpi,nn_hls,ipk,ipl,ipf) ) 
     225      ! 
     226      ! Load arrays to the south and to the north to be sent 
     227      IF( llsend_so )   THEN   ! Read Dirichlet lateral conditions 
     228         DO jf = 1, ipf 
     229            DO jl = 1, ipl 
     230               DO jk = 1, ipk 
     231                  DO jh = 1, nn_hls 
     232                     zsend_so(:,jh,jk,jl,jf) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 
     233                  END DO 
     234               END DO 
     235            END DO 
     236         END DO 
     237      END IF 
     238      ! 
     239      IF( llsend_no )   THEN   ! Read Dirichlet lateral conditions 
     240         ijhom = nlcj-nrecj 
     241         DO jf = 1, ipf 
     242            DO jl = 1, ipl 
     243               DO jk = 1, ipk 
     244                  DO jh = 1, nn_hls 
     245                     zsend_no(:,jh,jk,jl,jf) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 
     246                  END DO 
     247               END DO 
     248            END DO 
     249         END DO 
     250      END IF 
     251      ! 
     252      ! Send/receive arrays to the south and to the north 
     253      imigr = nn_hls * jpi * ipk * ipl * ipf   ! Migrations 
     254      ! 
     255      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     256      !  
     257      IF( llsend_no )   CALL mppsend( 4, zsend_no(1,1,1,1,1), imigr, nono, ml_req1 ) 
     258      IF( llsend_so )   CALL mppsend( 3, zsend_so(1,1,1,1,1), imigr, noso, ml_req2 ) 
     259      ! 
     260      IF( llrecv_no )   CALL mpprecv( 3, zrecv_no(1,1,1,1,1), imigr, nono ) 
     261      IF( llrecv_so )   CALL mpprecv( 4, zrecv_so(1,1,1,1,1), imigr, noso ) 
     262      ! 
     263      IF( l_isend .AND. llsend_no ) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     264      IF( l_isend .AND. llsend_so ) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     265      ! 
     266      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     267      ! 
     268      !                           ! Write Dirichlet lateral conditions 
     269      ! Update with the received arrays  
     270      IF( llrecv_so )   THEN 
     271         DO jf = 1, ipf 
     272            DO jl = 1, ipl 
     273               DO jk = 1, ipk 
     274                  DO jh = 1, nn_hls 
     275                     ARRAY_IN(:,      jh,jk,jl,jf) = zrecv_so(:,jh,jk,jl,jf) 
     276                  END DO 
     277               END DO 
     278            END DO 
     279         END DO 
     280      END IF 
     281      IF( llrecv_no )   THEN 
    274282         ijhom = nlcj-nn_hls 
    275          ! 
    276          SELECT CASE ( nbondj_bdy_b(IBD_IN(jf)) ) 
    277          CASE ( -1 ) 
    278             DO jl = 1, ipl 
    279                DO jk = 1, ipk 
    280                   DO jh = 1, nn_hls 
    281                      ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 
    282                   END DO 
    283                END DO 
    284             END DO 
    285          CASE ( 0 ) 
    286             DO jl = 1, ipl 
    287                DO jk = 1, ipk 
    288                   DO jh = 1, nn_hls 
    289                      ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 
    290                      ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 
    291                   END DO 
    292                END DO 
    293             END DO 
    294          CASE ( 1 ) 
    295             DO jl = 1, ipl 
    296                DO jk = 1, ipk 
    297                   DO jh = 1, nn_hls 
    298                      ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 
    299                   END DO 
    300                END DO 
    301             END DO 
    302          END SELECT 
    303       END DO 
    304       ! 
    305       DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  ) 
     283         DO jf = 1, ipf 
     284            DO jl = 1, ipl 
     285               DO jk = 1, ipk 
     286                  DO jh = 1, nn_hls 
     287                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zrecv_no(:,jh,jk,jl,jf) 
     288                  END DO 
     289               END DO 
     290            END DO 
     291         END DO 
     292      END IF 
     293      ! 
     294      ! Clean up 
     295      IF( llsend_so )   DEALLOCATE( zsend_so ) 
     296      IF( llsend_no )   DEALLOCATE( zsend_no ) 
     297      IF( llrecv_so )   DEALLOCATE( zrecv_so ) 
     298      IF( llrecv_no )   DEALLOCATE( zrecv_no ) 
    306299      ! 
    307300   END SUBROUTINE ROUTINE_BDY 
    … …  
    310303#undef NAT_IN 
    311304#undef SGN_IN 
    312 #undef IBD_IN 
    313305#undef ARRAY_IN 
    314306#undef K_SIZE 
    … …  
    316308#undef F_SIZE 
    317309#undef OPT_K 
     310 

  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/TOP/trcbdy.F90

    r10425 r11067  
    4949      REAL(wp), POINTER, DIMENSION(:,:) ::  ztrc 
    5050      REAL(wp), POINTER                 ::  zfac 
     51      LOGICAL, DIMENSION(4)             :: lsend1, lrecv1     ! indicate how communications are to be carried out 
    5152      !!---------------------------------------------------------------------- 
    5253      ! 
    … …  
    7071            CASE DEFAULT           ;   CALL ctl_stop( 'trc_bdy : unrecognised option for open boundaries for passive tracers' ) 
    7172            END SELECT 
    72             ! Boundary points should be updated 
    73             CALL lbc_bdy_lnk( 'trcbdy', tra(:,:,:,jn), 'T', 1., ib_bdy ) 
    7473            ! 
    7574         END DO 
    7675      END DO 
    7776      ! 
     77      lsend1(:) = .false. 
     78      lrecv1(:) = .false. 
     79      DO ib_bdy=1, nb_bdy 
     80         SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
     81         CASE('neumann') 
     82            lsend1(:) = lsend1(:) .OR. lsend_bdy(ib_bdy,1,:)   ! to   every bdy neighbour, T points 
     83            lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:)   ! from every bdy neighbour, T points 
     84         CASE('orlanski') 
     85            lsend1(:) = lsend1(:) .OR. lsend_bdy(ib_bdy,1,:)   ! to   every bdy neighbour, T points 
     86            lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:)   ! from every bdy neighbour, T points 
     87         CASE('orlanski_npo') 
     88            lsend1(:) = lsend1(:) .OR. lsend_bdy(ib_bdy,1,:)   ! to   every bdy neighbour, T points 
     89            lrecv1(:) = lrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:)   ! from every bdy neighbour, T points 
     90         END SELECT 
     91      END DO 
     92      IF( ANY(lsend1) .OR. ANY(lrecv1) ) THEN   ! if need to send/recv in at least one direction 
     93         CALL lbc_bdy_lnk( 'bdytra', lsend1, lrecv1, tsa, 'T',  1. ) 
     94      END IF 
     95      ! 
    7896      IF( ln_timing )   CALL timing_stop('trc_bdy') 
    79  
     97      ! 
    8098   END SUBROUTINE trc_bdy 
    8199 
Note: See TracChangeset for help on using the changeset viewer.