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 5930 for trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 – NEMO

Ignore:
Timestamp:
2015-11-26T17:07:10+01:00 (8 years ago)
Author:
jchanut
Message:

#1620 Merge free surface simplification into trunk

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r5656 r5930  
    2222   USE oce 
    2323   USE dom_oce       
    24    USE sol_oce 
    2524   USE agrif_oce 
    2625   USE phycst 
    … …  
    2928   USE lib_mpp 
    3029   USE wrk_nemo 
    31    USE dynspg_oce 
    3230   USE zdf_oce 
    3331  
    … …  
    3836 
    3937   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 
    40    PUBLIC   interpun, interpvn, interpun2d, interpvn2d  
     38   PUBLIC   interpun, interpvn 
    4139   PUBLIC   interptsn,  interpsshn 
    4240   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b 
    … …  
    8078      !! 
    8179      INTEGER :: ji,jj,jk, j1,j2, i1,i2 
    82       REAL(wp) :: timeref 
    83       REAL(wp) :: z2dt, znugdt 
    84       REAL(wp) :: zrhox, zrhoy 
    85       REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 
     80      REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb 
    8681      !!----------------------------------------------------------------------   
    8782 
    8883      IF( Agrif_Root() )   RETURN 
    8984 
    90       CALL wrk_alloc( jpi, jpj, spgv1, spgu1 ) 
     85      CALL wrk_alloc( jpi, jpj, zub, zvb ) 
    9186 
    9287      Agrif_SpecialValue=0. 
    … …  
    9691      CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 
    9792 
    98 #if defined key_dynspg_flt 
    99       CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 
    100       CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 
    101 #endif 
    102  
    10393      Agrif_UseSpecialValue = .FALSE. 
    104  
    105       zrhox = Agrif_Rhox() 
    106       zrhoy = Agrif_Rhoy() 
    107  
    108       timeref = 1. 
    109       ! time step: leap-frog 
    110       z2dt = 2. * rdt 
    111       ! time step: Euler if restart from rest 
    112       IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt 
    113       ! coefficients 
    114       znugdt =  grav * z2dt     
    115  
     94  
    11695      ! prevent smoothing in ghost cells 
    11796      i1=1 
    … …  
    126105 
    127106      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    128 #if defined key_dynspg_flt 
    129          DO jk=1,jpkm1 
     107 
     108         ! Smoothing 
     109         ! --------- 
     110         IF ( .NOT.ln_dynspg_ts ) THEN ! Store transport 
     111            ua_b(2,:)=0._wp 
     112            DO jk=1,jpkm1 
     113               DO jj=1,jpj 
     114                  ua_b(2,jj) = ua_b(2,jj) + fse3u_a(2,jj,jk) * ua(2,jj,jk) 
     115               END DO 
     116            END DO 
     117            DO jj=1,jpj 
     118               ua_b(2,jj) = ua_b(2,jj) * hur_a(2,jj)             
     119            END DO 
     120         ENDIF 
     121 
     122         DO jk=1,jpkm1                 ! Smooth 
    130123            DO jj=j1,j2 
    131                ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 
    132             END DO 
    133          END DO 
    134  
    135          spgu(2,:)=0. 
    136  
     124               ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 
     125               ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
     126            END DO 
     127         END DO 
     128 
     129         zub(2,:)=0._wp                ! Correct transport 
    137130         DO jk=1,jpkm1 
    138131            DO jj=1,jpj 
    139                spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
    140             END DO 
    141          END DO 
    142  
     132               zub(2,jj) = zub(2,jj) + fse3u_a(2,jj,jk) * ua(2,jj,jk) 
     133            END DO 
     134         END DO 
    143135         DO jj=1,jpj 
    144             IF (umask(2,jj,1).NE.0.) THEN 
    145                spgu(2,jj)=spgu(2,jj)/hu(2,jj) 
    146             ENDIF 
    147          END DO 
    148 #else 
    149          spgu(2,:) = ua_b(2,:) 
    150 #endif 
    151  
    152          DO jk=1,jpkm1 
     136            zub(2,jj) = zub(2,jj) * hur_a(2,jj) 
     137         END DO 
     138 
     139         DO jk=1,jpkm1 
     140            DO jj=1,jpj 
     141               ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 
     142            END DO 
     143         END DO 
     144 
     145         ! Set tangential velocities to time splitting estimate 
     146         !----------------------------------------------------- 
     147         IF ( ln_dynspg_ts) THEN 
     148            zvb(2,:)=0._wp 
     149            DO jk=1,jpkm1 
     150               DO jj=1,jpj 
     151                  zvb(2,jj) = zvb(2,jj) + fse3v_a(2,jj,jk) * va(2,jj,jk) 
     152               END DO 
     153            END DO 
     154            DO jj=1,jpj 
     155               zvb(2,jj) = zvb(2,jj) * hvr_a(2,jj) 
     156            END DO 
     157            DO jk=1,jpkm1 
     158               DO jj=1,jpj 
     159                  va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj))*vmask(2,jj,jk) 
     160               END DO 
     161            END DO 
     162         ENDIF 
     163 
     164         ! Mask domain edges: 
     165         !------------------- 
     166         DO jk=1,jpkm1 
     167            DO jj=1,jpj 
     168               ua(1,jj,jk) = 0._wp 
     169               va(1,jj,jk) = 0._wp 
     170            END DO 
     171         END DO          
     172 
     173      ENDIF 
     174 
     175      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     176 
     177         ! Smoothing 
     178         ! --------- 
     179         IF ( .NOT.ln_dynspg_ts ) THEN ! Store transport 
     180            ua_b(nlci-2,:)=0._wp 
     181            DO jk=1,jpkm1 
     182               DO jj=1,jpj 
     183                  ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + fse3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 
     184               END DO 
     185            END DO 
     186            DO jj=1,jpj 
     187               ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * hur_a(nlci-2,jj)             
     188            END DO 
     189         ENDIF 
     190 
     191         DO jk=1,jpkm1                 ! Smooth 
    153192            DO jj=j1,j2 
    154                ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 
    155                ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
    156             END DO 
    157          END DO 
    158  
    159          spgu1(2,:)=0. 
    160  
     193               ua(nlci-2,jj,jk) = 0.25_wp*(ua(nlci-3,jj,jk)+2._wp*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
     194               ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 
     195            END DO 
     196         END DO 
     197 
     198         zub(nlci-2,:)=0._wp           ! Correct transport 
    161199         DO jk=1,jpkm1 
    162200            DO jj=1,jpj 
    163                spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
    164             END DO 
    165          END DO 
    166  
     201               zub(nlci-2,jj) = zub(nlci-2,jj) + fse3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 
     202            END DO 
     203         END DO 
    167204         DO jj=1,jpj 
    168             IF (umask(2,jj,1).NE.0.) THEN 
    169                spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 
    170             ENDIF 
    171          END DO 
    172  
    173          DO jk=1,jpkm1 
    174             DO jj=j1,j2 
    175                ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 
    176             END DO 
    177          END DO 
    178  
    179 #if defined key_dynspg_ts 
     205            zub(nlci-2,jj) = zub(nlci-2,jj) * hur_a(nlci-2,jj) 
     206         END DO 
     207 
     208         DO jk=1,jpkm1 
     209            DO jj=1,jpj 
     210               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+ua_b(nlci-2,jj)-zub(nlci-2,jj))*umask(nlci-2,jj,jk) 
     211            END DO 
     212         END DO 
     213 
    180214         ! Set tangential velocities to time splitting estimate 
    181          spgv1(2,:)=0. 
    182          DO jk=1,jpkm1 
     215         !----------------------------------------------------- 
     216         IF ( ln_dynspg_ts) THEN 
     217            zvb(nlci-1,:)=0._wp 
     218            DO jk=1,jpkm1 
     219               DO jj=1,jpj 
     220                  zvb(nlci-1,jj) = zvb(nlci-1,jj) + fse3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 
     221               END DO 
     222            END DO 
    183223            DO jj=1,jpj 
    184                spgv1(2,jj)=spgv1(2,jj)+fse3v_a(2,jj,jk)*va(2,jj,jk) 
    185             END DO 
    186          END DO 
    187          DO jj=1,jpj 
    188             spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 
    189          END DO 
     224               zvb(nlci-1,jj) = zvb(nlci-1,jj) * hvr_a(nlci-1,jj) 
     225            END DO 
     226            DO jk=1,jpkm1 
     227               DO jj=1,jpj 
     228                  va(nlci-1,jj,jk) = (va(nlci-1,jj,jk)+va_b(nlci-1,jj)-zvb(nlci-1,jj))*vmask(nlci-1,jj,jk) 
     229               END DO 
     230            END DO 
     231         ENDIF 
     232 
     233         ! Mask domain edges: 
     234         !------------------- 
    190235         DO jk=1,jpkm1 
    191236            DO jj=1,jpj 
    192                va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-spgv1(2,jj))*vmask(2,jj,jk) 
    193             END DO 
    194          END DO 
    195 #endif 
    196  
    197       ENDIF 
    198  
    199       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    200 #if defined key_dynspg_flt 
    201          DO jk=1,jpkm1 
    202             DO jj=j1,j2 
    203                ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 
    204             END DO 
    205          END DO 
    206          spgu(nlci-2,:)=0. 
    207          DO jk=1,jpkm1 
    208             DO jj=1,jpj 
    209                spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
    210             ENDDO 
    211          ENDDO 
    212          DO jj=1,jpj 
    213             IF (umask(nlci-2,jj,1).NE.0.) THEN 
    214                spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 
    215             ENDIF 
    216          END DO 
    217 #else 
    218          spgu(nlci-2,:) = ua_b(nlci-2,:) 
    219 #endif 
    220          DO jk=1,jpkm1 
    221             DO jj=j1,j2 
    222                ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
    223  
    224                ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 
    225  
    226             END DO 
    227          END DO 
    228          spgu1(nlci-2,:)=0. 
    229          DO jk=1,jpkm1 
    230             DO jj=1,jpj 
    231                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 
    232             END DO 
    233          END DO 
    234          DO jj=1,jpj 
    235             IF (umask(nlci-2,jj,1).NE.0.) THEN 
    236                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 
    237             ENDIF 
    238          END DO 
    239          DO jk=1,jpkm1 
    240             DO jj=j1,j2 
    241                ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 
    242             END DO 
    243          END DO 
    244  
    245 #if defined key_dynspg_ts 
     237               ua(nlci-1,jj,jk) = 0._wp 
     238               va(nlci  ,jj,jk) = 0._wp 
     239            END DO 
     240         END DO  
     241 
     242      ENDIF 
     243 
     244      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     245 
     246         ! Smoothing 
     247         ! --------- 
     248         IF ( .NOT.ln_dynspg_ts ) THEN ! Store transport 
     249            va_b(:,2)=0._wp 
     250            DO jk=1,jpkm1 
     251               DO ji=1,jpi 
     252                  va_b(ji,2) = va_b(ji,2) + fse3v_a(ji,2,jk) * va(ji,2,jk) 
     253               END DO 
     254            END DO 
     255            DO ji=1,jpi 
     256               va_b(ji,2) = va_b(ji,2) * hvr_a(ji,2)             
     257            END DO 
     258         ENDIF 
     259 
     260         DO jk=1,jpkm1                 ! Smooth 
     261            DO ji=i1,i2 
     262               va(ji,2,jk)=0.25_wp*(va(ji,1,jk)+2._wp*va(ji,2,jk)+va(ji,3,jk)) 
     263               va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 
     264            END DO 
     265         END DO 
     266 
     267         zvb(:,2)=0._wp                ! Correct transport 
     268         DO jk=1,jpkm1 
     269            DO ji=1,jpi 
     270               zvb(ji,2) = zvb(ji,2) + fse3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 
     271            END DO 
     272         END DO 
     273         DO ji=1,jpi 
     274            zvb(ji,2) = zvb(ji,2) * hvr_a(ji,2) 
     275         END DO 
     276         DO jk=1,jpkm1 
     277            DO ji=1,jpi 
     278               va(ji,2,jk) = (va(ji,2,jk)+va_b(ji,2)-zvb(ji,2))*vmask(ji,2,jk) 
     279            END DO 
     280         END DO 
     281 
    246282         ! Set tangential velocities to time splitting estimate 
    247          spgv1(nlci-1,:)=0._wp 
    248          DO jk=1,jpkm1 
    249             DO jj=1,jpj 
    250                spgv1(nlci-1,jj)=spgv1(nlci-1,jj)+fse3v_a(nlci-1,jj,jk)*va(nlci-1,jj,jk)*vmask(nlci-1,jj,jk) 
    251             END DO 
    252          END DO 
    253  
    254          DO jj=1,jpj 
    255             spgv1(nlci-1,jj)=spgv1(nlci-1,jj)*hvr_a(nlci-1,jj) 
    256          END DO 
    257  
    258          DO jk=1,jpkm1 
    259             DO jj=1,jpj 
    260                va(nlci-1,jj,jk) = (va(nlci-1,jj,jk)+va_b(nlci-1,jj)-spgv1(nlci-1,jj))*vmask(nlci-1,jj,jk) 
    261             END DO 
    262          END DO 
    263 #endif 
    264  
    265       ENDIF 
    266  
    267       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    268  
    269 #if defined key_dynspg_flt 
    270          DO jk=1,jpkm1 
     283         !----------------------------------------------------- 
     284         IF ( ln_dynspg_ts ) THEN 
     285            zub(:,2)=0._wp 
     286            DO jk=1,jpkm1 
     287               DO ji=1,jpi 
     288                  zub(ji,2) = zub(ji,2) + fse3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 
     289               END DO 
     290            END DO 
    271291            DO ji=1,jpi 
    272                va(ji,2,jk) = (va(ji,2,jk) - z2dt * znugdt * laplacv(ji,2))*vmask(ji,2,jk) 
    273             END DO 
    274          END DO 
    275  
    276          spgv(:,2)=0. 
    277  
     292               zub(ji,2) = zub(ji,2) * hur_a(ji,2) 
     293            END DO 
     294 
     295            DO jk=1,jpkm1 
     296               DO ji=1,jpi 
     297                  ua(ji,2,jk) = (ua(ji,2,jk)+ua_b(ji,2)-zub(ji,2))*umask(ji,2,jk) 
     298               END DO 
     299            END DO 
     300         ENDIF 
     301 
     302         ! Mask domain edges: 
     303         !------------------- 
    278304         DO jk=1,jpkm1 
    279305            DO ji=1,jpi 
    280                spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 
    281             END DO 
    282          END DO 
    283  
     306               ua(ji,1,jk) = 0._wp 
     307               va(ji,1,jk) = 0._wp 
     308            END DO 
     309         END DO  
     310 
     311      ENDIF 
     312 
     313      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     314         ! Smoothing 
     315         ! --------- 
     316         IF ( .NOT.ln_dynspg_ts ) THEN ! Store transport 
     317            va_b(:,nlcj-2)=0._wp 
     318            DO jk=1,jpkm1 
     319               DO ji=1,jpi 
     320                  va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + fse3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) 
     321               END DO 
     322            END DO 
     323            DO ji=1,jpi 
     324               va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * hvr_a(ji,nlcj-2)             
     325            END DO 
     326         ENDIF 
     327 
     328         DO jk=1,jpkm1                 ! Smooth 
     329            DO ji=i1,i2 
     330               va(ji,nlcj-2,jk)=0.25_wp*(va(ji,nlcj-3,jk)+2._wp*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 
     331               va(ji,nlcj-2,jk)=va(ji,nlcj-2,jk)*vmask(ji,nlcj-2,jk) 
     332            END DO 
     333         END DO 
     334 
     335         zvb(:,nlcj-2)=0._wp           ! Correct transport 
     336         DO jk=1,jpkm1 
     337            DO ji=1,jpi 
     338               zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + fse3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
     339            END DO 
     340         END DO 
    284341         DO ji=1,jpi 
    285             IF (vmask(ji,2,1).NE.0.) THEN 
    286                spgv(ji,2)=spgv(ji,2)/hv(ji,2) 
    287             ENDIF 
    288          END DO 
    289 #else 
    290          spgv(:,2)=va_b(:,2) 
    291 #endif 
    292  
    293          DO jk=1,jpkm1 
    294             DO ji=i1,i2 
    295                va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 
    296                va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 
    297             END DO 
    298          END DO 
    299  
    300          spgv1(:,2)=0. 
    301  
     342            zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * hvr_a(ji,nlcj-2) 
     343         END DO 
    302344         DO jk=1,jpkm1 
    303345            DO ji=1,jpi 
    304                spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
    305             END DO 
    306          END DO 
    307  
    308          DO ji=1,jpi 
    309             IF (vmask(ji,2,1).NE.0.) THEN 
    310                spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 
    311             ENDIF 
    312          END DO 
    313  
    314          DO jk=1,jpkm1 
     346               va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+va_b(ji,nlcj-2)-zvb(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 
     347            END DO 
     348         END DO 
     349 
     350         ! Set tangential velocities to time splitting estimate 
     351         !----------------------------------------------------- 
     352         IF ( ln_dynspg_ts ) THEN 
     353            zub(:,nlcj-1)=0._wp 
     354            DO jk=1,jpkm1 
     355               DO ji=1,jpi 
     356                  zub(ji,nlcj-1) = zub(ji,nlcj-1) + fse3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 
     357               END DO 
     358            END DO 
    315359            DO ji=1,jpi 
    316                va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 
    317             END DO 
    318          END DO 
    319  
    320 #if defined key_dynspg_ts 
    321          ! Set tangential velocities to time splitting estimate 
    322          spgu1(:,2)=0._wp 
     360               zub(ji,nlcj-1) = zub(ji,nlcj-1) * hur_a(ji,nlcj-1) 
     361            END DO 
     362 
     363            DO jk=1,jpkm1 
     364               DO ji=1,jpi 
     365                  ua(ji,nlcj-1,jk) = (ua(ji,nlcj-1,jk)+ua_b(ji,nlcj-1)-zub(ji,nlcj-1))*umask(ji,nlcj-1,jk) 
     366               END DO 
     367            END DO 
     368         ENDIF 
     369 
     370         ! Mask domain edges: 
     371         !------------------- 
    323372         DO jk=1,jpkm1 
    324373            DO ji=1,jpi 
    325                spgu1(ji,2)=spgu1(ji,2)+fse3u_a(ji,2,jk)*ua(ji,2,jk)*umask(ji,2,jk) 
    326             END DO 
    327          END DO 
    328  
    329          DO ji=1,jpi 
    330             spgu1(ji,2)=spgu1(ji,2)*hur_a(ji,2) 
    331          END DO 
    332  
    333          DO jk=1,jpkm1 
    334             DO ji=1,jpi 
    335                ua(ji,2,jk) = (ua(ji,2,jk)+ua_b(ji,2)-spgu1(ji,2))*umask(ji,2,jk) 
    336             END DO 
    337          END DO 
    338 #endif 
    339       ENDIF 
    340  
    341       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    342  
    343 #if defined key_dynspg_flt 
    344          DO jk=1,jpkm1 
    345             DO ji=1,jpi 
    346                va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)-z2dt * znugdt * laplacv(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 
    347             END DO 
    348          END DO 
    349  
    350  
    351          spgv(:,nlcj-2)=0. 
    352  
    353          DO jk=1,jpkm1 
    354             DO ji=1,jpi 
    355                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    356             END DO 
    357          END DO 
    358  
    359          DO ji=1,jpi 
    360             IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    361                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 
    362             ENDIF 
    363          END DO 
    364  
    365 #else 
    366          spgv(:,nlcj-2)=va_b(:,nlcj-2) 
    367 #endif 
    368  
    369          DO jk=1,jpkm1 
    370             DO ji=i1,i2 
    371                va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 
    372                va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
    373             END DO 
    374          END DO 
    375  
    376          spgv1(:,nlcj-2)=0. 
    377  
    378          DO jk=1,jpkm1 
    379             DO ji=1,jpi 
    380                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    381             END DO 
    382          END DO 
    383  
    384          DO ji=1,jpi 
    385             IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    386                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 
    387             ENDIF 
    388          END DO 
    389  
    390          DO jk=1,jpkm1 
    391             DO ji=1,jpi 
    392                va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 
    393             END DO 
    394          END DO 
    395  
    396 #if defined key_dynspg_ts 
    397          ! Set tangential velocities to time splitting estimate 
    398          spgu1(:,nlcj-1)=0._wp 
    399          DO jk=1,jpkm1 
    400             DO ji=1,jpi 
    401                spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)+fse3u_a(ji,nlcj-1,jk)*ua(ji,nlcj-1,jk) 
    402             END DO 
    403          END DO 
    404  
    405          DO ji=1,jpi 
    406             spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)*hur_a(ji,nlcj-1) 
    407          END DO 
    408  
    409          DO jk=1,jpkm1 
    410             DO ji=1,jpi 
    411                ua(ji,nlcj-1,jk) = (ua(ji,nlcj-1,jk)+ua_b(ji,nlcj-1)-spgu1(ji,nlcj-1))*umask(ji,nlcj-1,jk) 
    412             END DO 
    413          END DO 
    414 #endif 
    415  
    416       ENDIF 
    417       ! 
    418       CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 
     374               ua(ji,nlcj  ,jk) = 0._wp 
     375               va(ji,nlcj-1,jk) = 0._wp 
     376            END DO 
     377         END DO  
     378 
     379      ENDIF 
     380      ! 
     381      CALL wrk_dealloc( jpi, jpj, zub, zvb ) 
    419382      ! 
    420383   END SUBROUTINE Agrif_dyn 
    … …  
    687650                  END DO 
    688651               END DO 
     652               tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 
    689653            ENDDO 
    690654         ENDIF 
    … …  
    706670                  END DO 
    707671               END DO 
     672               tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 
    708673            ENDDO 
    709674         ENDIF 
    … …  
    724689                  END DO 
    725690               END DO 
     691               tsa(1,j1:j2,k1:k2,jn) = 0._wp 
    726692            END DO 
    727693         ENDIF 
    … …  
    742708                  END DO 
    743709               END DO 
     710               tsa(i1:i2,1,k1:k2,jn) = 0._wp 
    744711            ENDDO 
    745712         ENDIF 
    … …  
    828795   END SUBROUTINE interpun 
    829796 
    830  
    831    SUBROUTINE interpun2d(ptab,i1,i2,j1,j2,before) 
    832       !!--------------------------------------------- 
    833       !!   *** ROUTINE interpun *** 
    834       !!---------------------------------------------     
    835       ! 
    836       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    837       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
    838       LOGICAL, INTENT(in) :: before 
    839       ! 
    840       INTEGER :: ji,jj 
    841       REAL(wp) :: ztref 
    842       REAL(wp) :: zrhoy  
    843       !!---------------------------------------------     
    844       ! 
    845       ztref = 1. 
    846  
    847       IF (before) THEN  
    848          DO jj=j1,j2 
    849             DO ji=i1,MIN(i2,nlci-1) 
    850                ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj))  
    851             END DO 
    852          END DO 
    853       ELSE 
    854          zrhoy = Agrif_Rhoy() 
    855          DO jj=j1,j2 
    856             laplacu(i1:i2,jj) = ztref * (ptab(i1:i2,jj)/(zrhoy*e2u(i1:i2,jj))) !*umask(i1:i2,jj,1) 
    857          END DO 
    858       ENDIF 
    859       !  
    860    END SUBROUTINE interpun2d 
    861  
    862  
    863797   SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 
    864798      !!--------------------------------------------- 
    … …  
    895829      !         
    896830   END SUBROUTINE interpvn 
    897  
    898    SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 
    899       !!--------------------------------------------- 
    900       !!   *** ROUTINE interpvn *** 
    901       !!---------------------------------------------     
    902       ! 
    903       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    904       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
    905       LOGICAL, INTENT(in) :: before 
    906       ! 
    907       INTEGER :: ji,jj 
    908       REAL(wp) :: zrhox  
    909       REAL(wp) :: ztref 
    910       !!---------------------------------------------     
    911       !  
    912       ztref = 1.     
    913       IF (before) THEN  
    914          !interpv entre 1 et k2 et interpv2d en jpkp1 
    915          DO jj=j1,MIN(j2,nlcj-1) 
    916             DO ji=i1,i2 
    917                ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 
    918             END DO 
    919          END DO 
    920       ELSE            
    921          zrhox = Agrif_Rhox() 
    922          DO ji=i1,i2 
    923             laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 
    924          END DO 
    925       ENDIF 
    926       !       
    927    END SUBROUTINE interpvn2d 
    928831 
    929832   SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 
Note: See TracChangeset for help on using the changeset viewer.