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 11536 for NEMO/trunk/src/OCE/BDY/bdydyn3d.F90 – NEMO

Ignore:
Timestamp:
2019-09-11T15:54:18+02:00 (5 years ago)
Author:
smasson
Message:

trunk: merge dev_r10984_HPC-13 into the trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • NEMO/trunk/src/OCE/BDY/bdydyn3d.F90

    r10529 r11536  
    4242      INTEGER, INTENT(in) ::   kt   ! Main time step counter 
    4343      ! 
    44       INTEGER ::   ib_bdy   ! loop index 
    45       !!---------------------------------------------------------------------- 
    46       ! 
    47       DO ib_bdy=1, nb_bdy 
     44      INTEGER  ::   ib_bdy, ir     ! BDY set index, rim index 
     45      LOGICAL  ::   llrim0         ! indicate if rim 0 is treated 
     46      LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3  ! indicate how communications are to be carried out 
     47 
     48      !!---------------------------------------------------------------------- 
     49      llsend2(:) = .false.   ;   llrecv2(:) = .false. 
     50      llsend3(:) = .false.   ;   llrecv3(:) = .false. 
     51      DO ir = 1, 0, -1   ! treat rim 1 before rim 0 
     52         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
     53         ELSE                 ;   llrim0 = .FALSE. 
     54         END IF 
     55         DO ib_bdy=1, nb_bdy 
     56            ! 
     57            SELECT CASE( cn_dyn3d(ib_bdy) ) 
     58            CASE('none')        ;   CYCLE 
     59            CASE('frs' )        ! treat the whole boundary at once 
     60               IF( ir == 0) CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     61            CASE('specified')   ! treat the whole rim      at once 
     62               IF( ir == 0) CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     63            CASE('zero')        ! treat the whole rim      at once 
     64               IF( ir == 0) CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     65            CASE('orlanski' )   ;   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.false. ) 
     66            CASE('orlanski_npo');   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.true.  ) 
     67            CASE('zerograd')    ;   CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy, llrim0 ) 
     68            CASE('neumann')     ;   CALL bdy_dyn3d_nmn( idx_bdy(ib_bdy), ib_bdy, llrim0 ) 
     69            CASE DEFAULT        ;   CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 
     70            END SELECT 
     71         END DO 
    4872         ! 
    49          SELECT CASE( cn_dyn3d(ib_bdy) ) 
    50          CASE('none')        ;   CYCLE 
    51          CASE('frs' )        ;   CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    52          CASE('specified')   ;   CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    53          CASE('zero')        ;   CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    54          CASE('orlanski' )   ;   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. ) 
    55          CASE('orlanski_npo');   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. ) 
    56          CASE('zerograd')    ;   CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    57          CASE('neumann')     ;   CALL bdy_dyn3d_nmn( idx_bdy(ib_bdy), ib_bdy ) 
    58          CASE DEFAULT        ;   CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 
    59          END SELECT 
    60       END DO 
     73         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     74         IF( nn_hls == 1 ) THEN 
     75            llsend2(:) = .false.   ;   llrecv2(:) = .false. 
     76            llsend3(:) = .false.   ;   llrecv3(:) = .false. 
     77         END IF 
     78         DO ib_bdy=1, nb_bdy 
     79            SELECT CASE( cn_dyn3d(ib_bdy) ) 
     80            CASE('orlanski', 'orlanski_npo') 
     81               llsend2(:) = llsend2(:) .OR. lsend_bdy(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     82               llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     83               llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     84               llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     85            CASE('zerograd') 
     86               llsend2(3:4) = llsend2(3:4) .OR. lsend_bdyint(ib_bdy,2,3:4,ir)   ! north/south, U points 
     87               llrecv2(3:4) = llrecv2(3:4) .OR. lrecv_bdyint(ib_bdy,2,3:4,ir)   ! north/south, U points 
     88               llsend3(1:2) = llsend3(1:2) .OR. lsend_bdyint(ib_bdy,3,1:2,ir)   ! west/east, V points 
     89               llrecv3(1:2) = llrecv3(1:2) .OR. lrecv_bdyint(ib_bdy,3,1:2,ir)   ! west/east, V points 
     90            CASE('neumann') 
     91               llsend2(:) = llsend2(:) .OR. lsend_bdyint(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     92               llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     93               llsend3(:) = llsend3(:) .OR. lsend_bdyint(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     94               llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     95            END SELECT 
     96         END DO 
     97         ! 
     98         IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN   ! if need to send/recv in at least one direction 
     99            CALL lbc_lnk( 'bdydyn2d', ua, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
     100         END IF 
     101         IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN   ! if need to send/recv in at least one direction 
     102            CALL lbc_lnk( 'bdydyn2d', va, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
     103         END IF 
     104      END DO   ! ir 
    61105      ! 
    62106   END SUBROUTINE bdy_dyn3d 
     
    78122      INTEGER  ::   jb, jk         ! dummy loop indices 
    79123      INTEGER  ::   ii, ij, igrd   ! local integers 
    80       REAL(wp) ::   zwgt           ! boundary weight 
    81124      !!---------------------------------------------------------------------- 
    82125      ! 
     
    98141         END DO 
    99142      END DO 
    100       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
    101       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    102       ! 
    103       IF( kt == nit000 )   CLOSE( unit = 102 ) 
    104143      ! 
    105144   END SUBROUTINE bdy_dyn3d_spe 
    106145 
    107146 
    108    SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt , ib_bdy ) 
     147   SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt, ib_bdy, llrim0 ) 
    109148      !!---------------------------------------------------------------------- 
    110149      !!                  ***  SUBROUTINE bdy_dyn3d_zgrad  *** 
     
    114153      !!---------------------------------------------------------------------- 
    115154      INTEGER                     ::   kt 
    116       TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    117       TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
    118       INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
     155      TYPE(OBC_INDEX), INTENT(in) ::   idx      ! OBC indices 
     156      TYPE(OBC_DATA),  INTENT(in) ::   dta      ! OBC external data 
     157      INTEGER,         INTENT(in) ::   ib_bdy   ! BDY set index 
     158      LOGICAL,         INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
    119159      !! 
    120160      INTEGER  ::   jb, jk         ! dummy loop indices 
    121161      INTEGER  ::   ii, ij, igrd   ! local integers 
    122       REAL(wp) ::   zwgt           ! boundary weight 
    123       INTEGER  ::   fu, fv 
     162      INTEGER  ::   flagu, flagv           ! short cuts 
     163      INTEGER  ::   ibeg, iend     ! length of rim to be treated (rim 0 or rim 1 or both) 
    124164      !!---------------------------------------------------------------------- 
    125165      ! 
    126166      igrd = 2                      ! Copying tangential velocity into bdy points 
    127       DO jb = 1, idx%nblenrim(igrd) 
    128          DO jk = 1, jpkm1 
    129             ii   = idx%nbi(jb,igrd) 
    130             ij   = idx%nbj(jb,igrd) 
    131             fu   = ABS( ABS (NINT( idx%flagu(jb,igrd) ) ) - 1 ) 
    132             ua(ii,ij,jk) = ua(ii,ij,jk) * REAL( 1 - fu) + ( ua(ii,ij+fu,jk) * umask(ii,ij+fu,jk) & 
    133                         &+ ua(ii,ij-fu,jk) * umask(ii,ij-fu,jk) ) * umask(ii,ij,jk) * REAL( fu ) 
    134          END DO 
     167      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd) 
     168      ELSE                ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd) 
     169      ENDIF 
     170      DO jb = ibeg, iend 
     171         ii    = idx%nbi(jb,igrd) 
     172         ij    = idx%nbj(jb,igrd) 
     173         flagu = NINT(idx%flagu(jb,igrd)) 
     174         flagv = NINT(idx%flagv(jb,igrd)) 
     175         ! 
     176         IF( flagu == 0 )   THEN              ! north/south bdy 
     177            IF( ij+flagv > jpj .OR. ij+flagv < 1 )   CYCLE       
     178            ! 
     179            DO jk = 1, jpkm1 
     180               ua(ii,ij,jk) = ua(ii,ij+flagv,jk) * umask(ii,ij+flagv,jk) 
     181            END DO 
     182            ! 
     183         END IF 
    135184      END DO 
    136185      ! 
    137186      igrd = 3                      ! Copying tangential velocity into bdy points 
    138       DO jb = 1, idx%nblenrim(igrd) 
    139          DO jk = 1, jpkm1 
    140             ii   = idx%nbi(jb,igrd) 
    141             ij   = idx%nbj(jb,igrd) 
    142             fv   = ABS( ABS (NINT( idx%flagv(jb,igrd) ) ) - 1 ) 
    143             va(ii,ij,jk) = va(ii,ij,jk) * REAL( 1 - fv ) + ( va(ii+fv,ij,jk) * vmask(ii+fv,ij,jk) & 
    144                         &+ va(ii-fv,ij,jk) * vmask(ii-fv,ij,jk) ) * vmask(ii,ij,jk) * REAL( fv ) 
    145          END DO 
    146       END DO 
    147       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
    148       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    149       ! 
    150       IF( kt == nit000 )   CLOSE( unit = 102 ) 
     187      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd) 
     188      ELSE                ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd) 
     189      ENDIF 
     190      DO jb = ibeg, iend 
     191         ii    = idx%nbi(jb,igrd) 
     192         ij    = idx%nbj(jb,igrd) 
     193         flagu = NINT(idx%flagu(jb,igrd)) 
     194         flagv = NINT(idx%flagv(jb,igrd)) 
     195         ! 
     196         IF( flagv == 0 )   THEN              !  west/east  bdy 
     197            IF( ii+flagu > jpi .OR. ii+flagu < 1 )   CYCLE       
     198            ! 
     199            DO jk = 1, jpkm1 
     200               va(ii,ij,jk) = va(ii+flagu,ij,jk) * vmask(ii+flagu,ij,jk) 
     201            END DO 
     202            ! 
     203         END IF 
     204      END DO 
    151205      ! 
    152206   END SUBROUTINE bdy_dyn3d_zgrad 
     
    167221      INTEGER  ::   ib, ik         ! dummy loop indices 
    168222      INTEGER  ::   ii, ij, igrd   ! local integers 
    169       REAL(wp) ::   zwgt           ! boundary weight 
    170223      !!---------------------------------------------------------------------- 
    171224      ! 
     
    178231         END DO 
    179232      END DO 
    180  
     233      ! 
    181234      igrd = 3                       ! Everything is at T-points here 
    182235      DO ib = 1, idx%nblenrim(igrd) 
     
    187240         END DO 
    188241      END DO 
    189       ! 
    190       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 
    191       ! 
    192       IF( kt == nit000 )   CLOSE( unit = 102 ) 
    193242      ! 
    194243   END SUBROUTINE bdy_dyn3d_zro 
     
    234283            va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta%v3d(jb,jk) - va(ii,ij,jk) ) ) * vmask(ii,ij,jk) 
    235284         END DO 
    236       END DO  
    237       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    238       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    239       ! 
    240       IF( kt == nit000 )   CLOSE( unit = 102 ) 
     285      END DO    
    241286      ! 
    242287   END SUBROUTINE bdy_dyn3d_frs 
    243288 
    244289 
    245    SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, ll_npo ) 
     290   SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, llrim0, ll_npo ) 
    246291      !!---------------------------------------------------------------------- 
    247292      !!                 ***  SUBROUTINE bdy_dyn3d_orlanski  *** 
     
    255300      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices 
    256301      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
    257       INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index 
    258       LOGICAL,                      INTENT(in) ::   ll_npo  ! switch for NPO version 
     302      INTEGER,                      INTENT(in) ::   ib_bdy   ! BDY set index 
     303      LOGICAL,                      INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
     304      LOGICAL,                      INTENT(in) ::   ll_npo   ! switch for NPO version 
    259305 
    260306      INTEGER  ::   jb, igrd                               ! dummy loop indices 
     
    265311      igrd = 2      ! Orlanski bc on u-velocity;  
    266312      !             
    267       CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo ) 
     313      CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo, llrim0 ) 
    268314 
    269315      igrd = 3      ! Orlanski bc on v-velocity 
    270316      !   
    271       CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo ) 
    272       ! 
    273       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    274       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
     317      CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo, llrim0 ) 
    275318      ! 
    276319   END SUBROUTINE bdy_dyn3d_orlanski 
     
    320363      END DO 
    321364      ! 
    322       CALL lbc_lnk_multi( 'bdydyn3d', ua, 'U', -1.,  va, 'V', -1. )   ! Boundary points should be updated 
    323       ! 
    324365      IF( ln_timing )   CALL timing_stop('bdy_dyn3d_dmp') 
    325366      ! 
     
    327368 
    328369 
    329    SUBROUTINE bdy_dyn3d_nmn( idx, ib_bdy ) 
     370   SUBROUTINE bdy_dyn3d_nmn( idx, ib_bdy, llrim0 ) 
    330371      !!---------------------------------------------------------------------- 
    331372      !!                 ***  SUBROUTINE bdy_dyn3d_nmn  *** 
     
    336377      !! 
    337378      !!---------------------------------------------------------------------- 
    338       TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices 
    339       INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index 
    340  
    341       INTEGER  ::   jb, igrd                               ! dummy loop indices 
     379      TYPE(OBC_INDEX), INTENT(in) ::   idx      ! OBC indices 
     380      INTEGER,         INTENT(in) ::   ib_bdy   ! BDY set index 
     381      LOGICAL,         INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
     382      INTEGER  ::   igrd                        ! dummy indice 
    342383      !!---------------------------------------------------------------------- 
    343384      ! 
     
    346387      igrd = 2      ! Neumann bc on u-velocity;  
    347388      !             
    348       CALL bdy_nmn( idx, igrd, ua ) 
     389      CALL bdy_nmn( idx, igrd, ua, llrim0 )   ! ua is masked 
    349390 
    350391      igrd = 3      ! Neumann bc on v-velocity 
    351392      !   
    352       CALL bdy_nmn( idx, igrd, va ) 
    353       ! 
    354       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    355       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 
     393      CALL bdy_nmn( idx, igrd, va, llrim0 )   ! va is masked 
    356394      ! 
    357395   END SUBROUTINE bdy_dyn3d_nmn 
Note: See TracChangeset for help on using the changeset viewer.