Ignore:
Timestamp:
2019-10-18T12:52:29+02:00 (12 months ago)
Author:
francesca
Message:

add extra halo support- ticket #2009

File:
1 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/TRA/traadv_mus.F90

    r10425 r11719  
    3030   USE lib_mpp        ! distribued memory computing 
    3131   USE lbclnk         ! ocean lateral boundary condition (or mpp link)  
    32    USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     32   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
     33   USE halo_mng 
    3334 
    3435   IMPLICIT NONE 
     
    3637 
    3738   PUBLIC   tra_adv_mus   ! routine called by traadv.F90 
     39    
     40   REAL(wp), ALLOCATABLE, DIMENSION(:,:    ) ::   r1_e1e2t_exh2, r1_e1e2u_exh2, r1_e1e2v_exh2 
     41   REAL(wp), ALLOCATABLE, DIMENSION(:,:    ) ::   rnfmsk_exh2, upsmsk_exh2, mikt_exh2 
     42   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:  ) ::   tmask_exh2, wmask_exh2, umask_exh2, vmask_exh2 
     43   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:  ) ::   e3u_n_exh2, e3v_n_exh2, e3t_n_exh2, e3w_n_exh2 
     44   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:  ) ::   pun_exh2, pvn_exh2, pwn_exh2   ! 3 ocean velocity components 
     45   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   ptb_exh2, pta_exh2        ! before and now tracer fields 
     46 
    3847    
    3948   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   upsmsk   !: mixed upstream/centered scheme near some straits 
     
    4453   LOGICAL  ::   l_ptr   ! flag to compute poleward transport 
    4554   LOGICAL  ::   l_hst   ! flag to compute heat/salt transport 
     55    
     56   INTEGER :: jphls = 2 
    4657 
    4758   !! * Substitutions 
     
    8495      ! 
    8596      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    86       INTEGER  ::   ierr             ! local integer 
     97      INTEGER  ::   last_khls, ierr             ! local integer 
    8798      REAL(wp) ::   zu, z0u, zzwx, zw , zalpha   ! local scalars 
    8899      REAL(wp) ::   zv, z0v, zzwy, z0w           !   -      - 
    89       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zslpx   ! 3D workspace 
    90       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwy, zslpy   ! -      -  
     100      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zwx, zslpx   ! 3D workspace 
     101      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zwy, zslpy   ! -      -  
    91102      !!---------------------------------------------------------------------- 
    92103      ! 
     104       
     105   CALL halo_mng_set(jphls) 
     106    
     107   ALLOCATE(zwx(jplbi:jpi,jplbj:jpj,jpk)) 
     108   ALLOCATE(zwy(jplbi:jpi,jplbj:jpj,jpk)) 
     109   ALLOCATE(zslpx(jplbi:jpi,jplbj:jpj,jpk)) 
     110   ALLOCATE(zslpy(jplbi:jpi,jplbj:jpj,jpk)) 
     111 
     112   IF (kt==kit000) THEN 
     113      if (.not. allocated(pun_exh2))   ALLOCATE(pun_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     114      if (.not. allocated(pvn_exh2))   ALLOCATE(pvn_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     115      if (.not. allocated(pwn_exh2))   ALLOCATE(pwn_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     116      if (.not. allocated(ptb_exh2))   ALLOCATE(ptb_exh2(jplbi:jpi,jplbj:jpj,jpk,kjpt)) 
     117      if (.not. allocated(pta_exh2))   ALLOCATE(pta_exh2(jplbi:jpi,jplbj:jpj,jpk,kjpt)) 
     118      if (.not. allocated(r1_e1e2t_exh2)) ALLOCATE(r1_e1e2t_exh2(jplbi:jpi,jplbj:jpj)) 
     119      if (.not. allocated(r1_e1e2u_exh2)) ALLOCATE(r1_e1e2u_exh2(jplbi:jpi,jplbj:jpj)) 
     120      if (.not. allocated(r1_e1e2v_exh2)) ALLOCATE(r1_e1e2v_exh2(jplbi:jpi,jplbj:jpj)) 
     121      if (.not. allocated(tmask_exh2)) ALLOCATE(tmask_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     122      if (.not. allocated(wmask_exh2)) ALLOCATE(wmask_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     123      if (.not. allocated(umask_exh2)) ALLOCATE(umask_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     124      if (.not. allocated(vmask_exh2)) ALLOCATE(vmask_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     125      if (.not. allocated(e3u_n_exh2)) ALLOCATE(e3u_n_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     126      if (.not. allocated(e3v_n_exh2)) ALLOCATE(e3v_n_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     127      if (.not. allocated(e3t_n_exh2)) ALLOCATE(e3t_n_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     128      if (.not. allocated(e3w_n_exh2)) ALLOCATE(e3w_n_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     129      IF( ln_isfcav.and..not.allocated(mikt_exh2)) ALLOCATE(mikt_exh2(jplbi:jpi,jplbj:jpj)) 
     130      IF( ld_msc_ups.and..not.allocated(rnfmsk_exh2)) ALLOCATE(rnfmsk_exh2(jplbi:jpi,jplbj:jpj)) 
     131      IF( ld_msc_ups.and..not.allocated(upsmsk_exh2)) ALLOCATE(upsmsk_exh2(jplbi:jpi,jplbj:jpj)) 
     132 
     133      CALL halo_mng_copy(r1_e1e2t, r1_e1e2t_exh2) 
     134      CALL halo_mng_copy(r1_e1e2u, r1_e1e2u_exh2) 
     135      CALL halo_mng_copy(r1_e1e2v, r1_e1e2v_exh2) 
     136      CALL halo_mng_copy(tmask, tmask_exh2) 
     137      CALL halo_mng_copy(wmask, wmask_exh2) 
     138      CALL halo_mng_copy(umask, umask_exh2) 
     139      CALL halo_mng_copy(vmask, vmask_exh2) 
     140 
     141      CALL lbc_lnk( 'traadv_mus', r1_e1e2u_exh2, 'U', -1.) 
     142      CALL lbc_lnk( 'traadv_mus', r1_e1e2v_exh2, 'V', -1.) 
     143      CALL lbc_lnk( 'traadv_mus', r1_e1e2t_exh2, 'T', 1.) 
     144      CALL lbc_lnk( 'traadv_mus', tmask_exh2, 'T', 1. ) 
     145      CALL lbc_lnk( 'traadv_mus', wmask_exh2, 'W', 1.) 
     146      CALL lbc_lnk( 'traadv_mus', umask_exh2, 'U', 1. ) 
     147      CALL lbc_lnk( 'traadv_mus', vmask_exh2, 'V', 1.) 
     148   ENDIF 
     149    
     150   IF( ln_isfcav ) THEN ; CALL halo_mng_copy(REAL(mikt), mikt_exh2) ; CALL lbc_lnk( 'traadv_mus', mikt_exh2, 'T', 1.) ; ENDIF 
     151   IF( ld_msc_ups) THEN ; CALL halo_mng_copy(rnfmsk, rnfmsk_exh2) ; CALL lbc_lnk( 'traadv_mus', rnfmsk_exh2, 'T', 1.) ; ENDIF 
     152   IF( ld_msc_ups) THEN ; CALL halo_mng_copy(upsmsk, upsmsk_exh2) ; CALL lbc_lnk( 'traadv_mus', upsmsk_exh2, 'T', 1.) ; ENDIF 
     153 
     154   CALL halo_mng_copy(e3u_n, e3u_n_exh2) 
     155   CALL halo_mng_copy(e3v_n, e3v_n_exh2) 
     156   CALL halo_mng_copy(e3t_n, e3t_n_exh2) 
     157   CALL halo_mng_copy(e3w_n, e3w_n_exh2) 
     158   CALL halo_mng_copy(pun, pun_exh2) 
     159   CALL halo_mng_copy(pvn, pvn_exh2) 
     160   CALL halo_mng_copy(pwn, pwn_exh2) 
     161   CALL halo_mng_copy(ptb, ptb_exh2) 
     162   CALL halo_mng_copy(pta, pta_exh2) 
     163 
     164   CALL lbc_lnk( 'traadv_mus', e3u_n_exh2, 'U', -1., pfillval = 1.0_wp ) 
     165   CALL lbc_lnk( 'traadv_mus', e3v_n_exh2, 'V', -1., pfillval = 1.0_wp ) 
     166   CALL lbc_lnk( 'traadv_mus', e3t_n_exh2, 'T', 1., pfillval = 1.0_wp ) 
     167   CALL lbc_lnk( 'traadv_mus', e3w_n_exh2, 'W', 1., pfillval = 1.0_wp ) 
     168   CALL lbc_lnk( 'traadv_mus', pun_exh2, 'U', -1.) 
     169   CALL lbc_lnk( 'traadv_mus', pvn_exh2, 'V', -1.) 
     170   CALL lbc_lnk( 'traadv_mus', pwn_exh2, 'W', 1.) 
     171   CALL lbc_lnk( 'traadv_mus', pta_exh2, 'T', 1.) 
     172   CALL lbc_lnk( 'traadv_mus', ptb_exh2, 'T', 1.) 
     173 
     174#     define pun pun_exh2 
     175#     define pvn pvn_exh2 
     176#     define pwn pwn_exh2 
     177#     define ptb ptb_exh2 
     178#     define pta pta_exh2 
     179#     define r1_e1e2t r1_e1e2t_exh2 
     180#     define r1_e1e2u r1_e1e2u_exh2 
     181#     define r1_e1e2v r1_e1e2v_exh2 
     182#     define tmask tmask_exh2 
     183#     define wmask wmask_exh2 
     184#     define umask umask_exh2 
     185#     define vmask vmask_exh2 
     186#     define e3u_n e3u_n_exh2 
     187#     define e3v_n e3v_n_exh2 
     188#     define e3t_n e3t_n_exh2 
     189#     define e3w_n e3w_n_exh2 
     190#     define mikt mikt_exh2 
     191#     define rnfmsk rnfmsk_exh2 
     192#     define upsmsk upsmsk_exh2 
     193 
    93194      IF( kt == kit000 )  THEN 
    94195         IF(lwp) WRITE(numout,*) 
     
    100201         ! Upstream / MUSCL scheme indicator 
    101202         ! 
    102          ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) 
     203         ALLOCATE( xind(jplbi:jpi,jplbj:jpj,jpk), STAT=ierr ) 
    103204         xind(:,:,:) = 1._wp              ! set equal to 1 where up-stream is not needed 
    104205         ! 
    105206         IF( ld_msc_ups ) THEN            ! define the upstream indicator (if asked) 
    106             ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 
     207            ALLOCATE( upsmsk(jplbi:jpi,jplbj:jpj), STAT=ierr ) 
    107208            upsmsk(:,:) = 0._wp                             ! not upstream by default 
    108209            ! 
     
    132233         zwy(:,:,jpk) = 0._wp   
    133234         DO jk = 1, jpkm1                       ! interior values 
    134             DO jj = 1, jpjm1       
    135                DO ji = 1, fs_jpim1   ! vector opt. 
     235            DO jj = jplbj, jpj-1       
     236               DO ji = jplbi, jpi-1   ! vector opt. 
    136237                  zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptb(ji+1,jj,jk,jn) - ptb(ji,jj,jk,jn) ) 
    137238                  zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptb(ji,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) 
     
    140241         END DO 
    141242         ! lateral boundary conditions   (changed sign) 
    142          CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) 
     243         !CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) 
    143244         !                                !-- Slopes of tracer 
    144245         zslpx(:,:,jpk) = 0._wp                 ! bottom values 
    145246         zslpy(:,:,jpk) = 0._wp 
    146247         DO jk = 1, jpkm1                       ! interior values 
    147             DO jj = 2, jpj 
    148                DO ji = fs_2, jpi   ! vector opt. 
     248            DO jj = jplbj+1, jpj 
     249               DO ji = jplbi+1, jpi   ! vector opt. 
    149250                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
    150251                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
     
    156257         ! 
    157258         DO jk = 1, jpkm1                 !-- Slopes limitation 
    158             DO jj = 2, jpj 
    159                DO ji = fs_2, jpi   ! vector opt. 
     259            DO jj = jplbj+1, jpj 
     260               DO ji = jplbi+1, jpi   ! vector opt. 
    160261                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
    161262                     &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
     
    169270         ! 
    170271         DO jk = 1, jpkm1                 !-- MUSCL horizontal advective fluxes 
    171             DO jj = 2, jpjm1 
    172                DO ji = fs_2, fs_jpim1   ! vector opt. 
     272            DO jj = jplbj+1, jpj-1 
     273               DO ji = jplbi+1, jpi-1   ! vector opt. 
    173274                  ! MUSCL fluxes 
    174275                  z0u = SIGN( 0.5, pun(ji,jj,jk) ) 
     
    188289            END DO 
    189290         END DO 
    190          CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. )   ! lateral boundary conditions   (changed sign) 
     291         !CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. )   ! lateral boundary conditions   (changed sign) 
    191292         ! 
    192293         DO jk = 1, jpkm1                 !-- Tracer advective trend 
    193             DO jj = 2, jpjm1       
    194                DO ji = fs_2, fs_jpim1   ! vector opt. 
     294            DO jj = jplbj+1, jpj-1       
     295               DO ji = jplbi+1, jpi-1   ! vector opt. 
    195296                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )       & 
    196297                  &                                     + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )     & 
     
    220321         zslpx(:,:,1) = 0._wp                   ! surface values 
    221322         DO jk = 2, jpkm1                       ! interior value 
    222             DO jj = 1, jpj 
    223                DO ji = 1, jpi 
     323            DO jj = jplbj, jpj 
     324               DO ji = jplbi, jpi 
    224325                  zslpx(ji,jj,jk) =                     ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )  & 
    225326                     &            * (  0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  ) 
     
    228329         END DO 
    229330         DO jk = 2, jpkm1                 !-- Slopes limitation 
    230             DO jj = 1, jpj                      ! interior values 
    231                DO ji = 1, jpi 
     331            DO jj = jplbj, jpj                      ! interior values 
     332               DO ji = jplbi, jpi 
    232333                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
    233334                     &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
     
    237338         END DO 
    238339         DO jk = 1, jpk-2                 !-- vertical advective flux 
    239             DO jj = 2, jpjm1       
    240                DO ji = fs_2, fs_jpim1   ! vector opt. 
     340            DO jj = jplbj+1, jpj-1       
     341               DO ji = jplbi+1, jpi-1   ! vector opt. 
    241342                  z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 
    242343                  zalpha = 0.5 + z0w 
     
    250351         IF( ln_linssh ) THEN                   ! top values, linear free surface only 
    251352            IF( ln_isfcav ) THEN                      ! ice-shelf cavities (top of the ocean) 
    252                DO jj = 1, jpj 
    253                   DO ji = 1, jpi 
     353            DO jj = jplbj, jpj       
     354               DO ji = jplbi, jpi 
    254355                     zwx(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) 
    255356                  END DO 
     
    261362         ! 
    262363         DO jk = 1, jpkm1                 !-- vertical advective trend 
    263             DO jj = 2, jpjm1       
    264                DO ji = fs_2, fs_jpim1   ! vector opt. 
     364            DO jj = jplbj+1, jpj-1       
     365               DO ji = jplbi+1, jpi-1   ! vector opt. 
    265366                  pta(ji,jj,jk,jn) =  pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    266367               END DO 
     
    272373      END DO                     ! end of tracer loop 
    273374      ! 
     375#     undef pun 
     376#     undef pvn 
     377#     undef pwn 
     378#     undef ptb 
     379#     undef pta 
     380#     undef r1_e1e2t 
     381#     undef r1_e1e2u 
     382#     undef r1_e1e2v 
     383#     undef tmask 
     384#     undef wmask 
     385#     undef umask 
     386#     undef vmask 
     387#     undef e3u_n 
     388#     undef e3v_n 
     389#     undef e3t_n 
     390#     undef e3w_n 
     391#     undef mikt 
     392#     undef rnfmsk 
     393#     undef upsmsk 
     394 
     395   CALL halo_mng_copy(pta_exh2, pta) 
     396 
     397    last_khls = jphls - ((SIZE(pta_exh2, 1) - SIZE(pta, 1))/2) 
     398 
     399    CALL halo_mng_set(last_khls) 
     400 
     401   CALL lbc_lnk( 'traadv_mus', pta, 'T', 1. ) 
     402 
     403   IF( kt==nitend ) THEN 
     404      if (allocated(pun_exh2)) DEALLOCATE(pun_exh2) 
     405      if (allocated(pvn_exh2)) DEALLOCATE(pvn_exh2) 
     406      if (allocated(pwn_exh2)) DEALLOCATE(pwn_exh2) 
     407         if (allocated(ptb_exh2)) DEALLOCATE(ptb_exh2) 
     408      if (allocated(pta_exh2)) DEALLOCATE(pta_exh2) 
     409      if (allocated(r1_e1e2t_exh2)) DEALLOCATE(r1_e1e2t_exh2) 
     410      if (allocated(r1_e1e2u_exh2)) DEALLOCATE(r1_e1e2u_exh2) 
     411      if (allocated(r1_e1e2v_exh2)) DEALLOCATE(r1_e1e2v_exh2) 
     412      if (allocated(tmask_exh2)) DEALLOCATE(tmask_exh2) 
     413      if (allocated(wmask_exh2)) DEALLOCATE(wmask_exh2) 
     414      if (allocated(umask_exh2)) DEALLOCATE(umask_exh2) 
     415      if (allocated(vmask_exh2)) DEALLOCATE(vmask_exh2) 
     416      if (allocated(e3u_n_exh2)) DEALLOCATE(e3u_n_exh2) 
     417      if (allocated(e3v_n_exh2)) DEALLOCATE(e3v_n_exh2) 
     418      if (allocated(e3t_n_exh2)) DEALLOCATE(e3t_n_exh2) 
     419      if (allocated(e3w_n_exh2)) DEALLOCATE(e3w_n_exh2) 
     420         IF (ln_isfcav.and.allocated(mikt_exh2)) DEALLOCATE(mikt_exh2) 
     421         IF( ld_msc_ups.and.allocated(rnfmsk_exh2)) DEALLOCATE(rnfmsk_exh2) 
     422      IF( ld_msc_ups.and.allocated(upsmsk_exh2)) DEALLOCATE(upsmsk_exh2) 
     423 
     424    ENDIF 
     425 
     426   DEALLOCATE(zwx,zwy) 
     427    DEALLOCATE(zslpx,zslpy) 
    274428   END SUBROUTINE tra_adv_mus 
    275429 
Note: See TracChangeset for help on using the changeset viewer.