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 2789 for branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/NST_SRC – NEMO

Ignore:
Timestamp:
2011-06-27T13:18:25+02:00 (13 years ago)
Author:
cetlod
Message:

Implementation of the merge of TRA/TRP : first guess, see ticket #842

Location:
branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/NST_SRC
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

    r2715 r2789  
    3535   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) ::   spe1ur2, spe2vr2, spbtr3   !: ??? 
    3636    
    37    INTEGER :: tn_id, sn_id, tb_id, sb_id, ta_id, sa_id 
     37   INTEGER :: tsn_id,tsb_id,tsa_id 
    3838   INTEGER :: un_id, vn_id, ua_id, va_id 
    3939   INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id 
  • branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r2715 r2789  
    4848      !!---------------------------------------------------------------------- 
    4949      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    50       USE wrk_nemo, ONLY: wrk_3d_1, wrk_3d_2 
     50      USE wrk_nemo, ONLY: wrk_4d_1 
    5151      !! 
    52       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     52      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    5353      REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
    5454      REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
    55       REAL(wp), POINTER, DIMENSION(:,:,:) :: zta, zsa 
     55      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa 
    5656      !!---------------------------------------------------------------------- 
    5757      ! 
    5858      IF( Agrif_Root() )   RETURN 
    5959 
    60       zta => wrk_3d_1 ; zsa => wrk_3d_2 
    61       IF( wrk_in_use(3, 1,2) )THEN 
     60      ztsa => wrk_4d_1  
     61      IF( wrk_in_use(4, 1) )THEN 
    6262         CALL ctl_stop('agrif_tra: requested workspace arrays unavailable.') 
    6363         RETURN 
     
    6666      Agrif_SpecialValue    = 0.e0 
    6767      Agrif_UseSpecialValue = .TRUE. 
    68       zta(:,:,:) = 0.e0 
    69       zsa(:,:,:) = 0.e0 
    70  
    71       CALL Agrif_Bc_variable( zta, tn_id, procname = interptn ) 
    72       CALL Agrif_Bc_variable( zsa, sn_id, procname = interpsn ) 
     68      ztsa(:,:,:,:) = 0.e0 
     69 
     70      CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 
    7371      Agrif_UseSpecialValue = .FALSE. 
    7472 
     
    8785      IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    8886 
    89          ta(nlci,:,:) = alpha1 * zta(nlci,:,:) + alpha2 * zta(nlci-1,:,:) 
    90          sa(nlci,:,:) = alpha1 * zsa(nlci,:,:) + alpha2 * zsa(nlci-1,:,:) 
    91  
    92          DO jk = 1, jpkm1 
    93             DO jj = 1, jpj 
    94                IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    95                   ta(nlci-1,jj,jk) = ta(nlci,jj,jk) * tmask(nlci-1,jj,jk) 
    96                   sa(nlci-1,jj,jk) = sa(nlci,jj,jk) * tmask(nlci-1,jj,jk) 
    97                ELSE 
    98                   ta(nlci-1,jj,jk)=(alpha4*ta(nlci,jj,jk)+alpha3*ta(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 
    99                   sa(nlci-1,jj,jk)=(alpha4*sa(nlci,jj,jk)+alpha3*sa(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 
    100                   IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    101                      ta(nlci-1,jj,jk)=( alpha6*ta(nlci-2,jj,jk)+alpha5*ta(nlci,jj,jk)  & 
    102                         &             + alpha7*ta(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 
    103                      sa(nlci-1,jj,jk)=( alpha6*sa(nlci-2,jj,jk)+alpha5*sa(nlci,jj,jk)  & 
    104                         &             + alpha7*sa(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 
     87         DO jn = 1, jpts 
     88            tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn) 
     89            DO jk = 1, jpkm1 
     90               DO jj = 1, jpj 
     91                  IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     92                     tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     93                  ELSE 
     94                     tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     95                     IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     96                        tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn)  & 
     97                           &                 + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     98                     ENDIF 
    10599                  ENDIF 
    106                ENDIF 
    107             END DO 
    108          END DO 
     100               END DO 
     101            END DO 
     102         ENDDO 
    109103      ENDIF 
    110104 
    111105      IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
    112106 
    113          ta(:,nlcj,:) = alpha1 * zta(:,nlcj,:) + alpha2 * zta(:,nlcj-1,:) 
    114          sa(:,nlcj,:) = alpha1 * zsa(:,nlcj,:) + alpha2 * zsa(:,nlcj-1,:) 
    115  
    116          DO jk = 1, jpkm1 
    117             DO ji = 1, jpi 
    118                IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    119                   ta(ji,nlcj-1,jk) = ta(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 
    120                   sa(ji,nlcj-1,jk) = sa(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 
    121                ELSE 
    122                   ta(ji,nlcj-1,jk)=(alpha4*ta(ji,nlcj,jk)+alpha3*ta(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk)         
    123                   sa(ji,nlcj-1,jk)=(alpha4*sa(ji,nlcj,jk)+alpha3*sa(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 
    124                   IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    125                      ta(ji,nlcj-1,jk)=( alpha6*ta(ji,nlcj-2,jk)+alpha5*ta(ji,nlcj,jk)  & 
    126                         &             + alpha7*ta(ji,nlcj-3,jk) ) * tmask(ji,nlcj-1,jk) 
    127                      sa(ji,nlcj-1,jk)=( alpha6*sa(ji,nlcj-2,jk)+alpha5*sa(ji,nlcj,jk)  & 
    128                         &             + alpha7*sa(ji,nlcj-3,jk))*tmask(ji,nlcj-1,jk) 
     107         DO jn = 1, jpts 
     108            tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn) 
     109            DO jk = 1, jpkm1 
     110               DO ji = 1, jpi 
     111                  IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     112                     tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     113                  ELSE 
     114                     tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     115                     IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     116                        tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn)  & 
     117                           &                 + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     118                     ENDIF 
    129119                  ENDIF 
    130                ENDIF 
    131             END DO 
    132          END DO 
     120               END DO 
     121            END DO 
     122         ENDDO  
    133123      ENDIF 
    134124 
    135125      IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    136          ta(1,:,:) = alpha1 * zta(1,:,:) + alpha2 * zta(2,:,:) 
    137          sa(1,:,:) = alpha1 * zsa(1,:,:) + alpha2 * zsa(2,:,:)       
    138          DO jk = 1, jpkm1 
    139             DO jj = 1, jpj 
    140                IF( umask(2,jj,jk) == 0.e0 ) THEN 
    141                   ta(2,jj,jk) = ta(1,jj,jk) * tmask(2,jj,jk) 
    142                   sa(2,jj,jk) = sa(1,jj,jk) * tmask(2,jj,jk) 
    143                ELSE 
    144                   ta(2,jj,jk)=(alpha4*ta(1,jj,jk)+alpha3*ta(3,jj,jk))*tmask(2,jj,jk)         
    145                   sa(2,jj,jk)=(alpha4*sa(1,jj,jk)+alpha3*sa(3,jj,jk))*tmask(2,jj,jk) 
    146                   IF( un(2,jj,jk) < 0.e0 ) THEN 
    147                      ta(2,jj,jk)=(alpha6*ta(3,jj,jk)+alpha5*ta(1,jj,jk)+alpha7*ta(4,jj,jk))*tmask(2,jj,jk) 
    148                      sa(2,jj,jk)=(alpha6*sa(3,jj,jk)+alpha5*sa(1,jj,jk)+alpha7*sa(4,jj,jk))*tmask(2,jj,jk) 
     126         DO jn = 1, jpts 
     127            tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn) 
     128            DO jk = 1, jpkm1 
     129               DO jj = 1, jpj 
     130                  IF( umask(2,jj,jk) == 0.e0 ) THEN 
     131                     tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
     132                  ELSE 
     133                     tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
     134                     IF( un(2,jj,jk) < 0.e0 ) THEN 
     135                        tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
     136                     ENDIF 
    149137                  ENDIF 
    150                ENDIF 
     138               END DO 
    151139            END DO 
    152140         END DO 
     
    154142 
    155143      IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    156          ta(:,1,:) = alpha1 * zta(:,1,:) + alpha2 * zta(:,2,:) 
    157          sa(:,1,:) = alpha1 * zsa(:,1,:) + alpha2 * zsa(:,2,:) 
    158          DO jk=1,jpk       
    159             DO ji=1,jpi 
    160                IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    161                   ta(ji,2,jk)=ta(ji,1,jk) * tmask(ji,2,jk) 
    162                   sa(ji,2,jk)=sa(ji,1,jk) * tmask(ji,2,jk) 
    163                ELSE 
    164                   ta(ji,2,jk)=(alpha4*ta(ji,1,jk)+alpha3*ta(ji,3,jk))*tmask(ji,2,jk) 
    165                   sa(ji,2,jk)=(alpha4*sa(ji,1,jk)+alpha3*sa(ji,3,jk))*tmask(ji,2,jk)  
    166                   IF( vn(ji,2,jk) < 0.e0 ) THEN 
    167                      ta(ji,2,jk)=(alpha6*ta(ji,3,jk)+alpha5*ta(ji,1,jk)+alpha7*ta(ji,4,jk))*tmask(ji,2,jk) 
    168                      sa(ji,2,jk)=(alpha6*sa(ji,3,jk)+alpha5*sa(ji,1,jk)+alpha7*sa(ji,4,jk))*tmask(ji,2,jk) 
     144         DO jn = 1, jpts 
     145            tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn) 
     146            DO jk=1,jpk       
     147               DO ji=1,jpi 
     148                  IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     149                     tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
     150                  ELSE 
     151                     tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
     152                     IF( vn(ji,2,jk) < 0.e0 ) THEN 
     153                        tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
     154                     ENDIF 
    169155                  ENDIF 
    170                ENDIF 
    171             END DO 
    172          END DO 
     156               END DO 
     157            END DO 
     158         ENDDO 
    173159      ENDIF 
    174160      ! 
    175       IF( wrk_not_released(3, 1,2) ) THEN 
     161      IF( wrk_not_released(4, 1) ) THEN 
    176162         CALL ctl_stop('agrif_tra: failed to release workspace arrays.') 
    177163      ENDIF 
  • branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90

    r2715 r2789  
    1212   PRIVATE 
    1313 
    14    PUBLIC Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptn, interpsn, interpun, interpvn 
     14   PUBLIC Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptsn, interpun, interpvn 
    1515 
    1616   !!---------------------------------------------------------------------- 
     
    2828#include "domzgr_substitute.h90" 
    2929      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    30       USE wrk_nemo, ONLY: wrk_2d_1 
    31       USE wrk_nemo, ONLY: wrk_3d_1, wrk_3d_2 
    32       USE wrk_nemo, ONLY: wrk_3d_3, wrk_3d_4 
    33       USE wrk_nemo, ONLY: wrk_3d_7, wrk_3d_6 
    34       USE wrk_nemo, ONLY: wrk_3d_8 
     30      USE wrk_nemo, ONLY: wrk_2d_1, wrk_2d_2, wrk_2d_3 
     31      USE wrk_nemo, ONLY: wrk_4d_1, wrk_4d_2 
    3532      !! 
    36       INTEGER :: ji,jj,jk 
     33      INTEGER :: ji,jj,jk,jn 
    3734      INTEGER :: spongearea 
    3835      REAL(wp) :: timecoeff 
    39       REAL(wp) :: zta, zsa, zabe1, zabe2, zbtr 
    40       REAL(wp), POINTER, DIMENSION(:,:) :: localviscsponge 
    41       REAL(wp), POINTER, DIMENSION(:,:,:) :: tbdiff, sbdiff 
    42       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztu, zsu, ztv, zsv 
    43       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
     36      REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
     37      REAL(wp), POINTER, DIMENSION(:,:    ) :: localviscsponge 
     38      REAL(wp), POINTER, DIMENSION(:,:    ) :: ztu, ztv 
     39      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
     40      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: tsbdiff 
    4441 
    4542#if defined SPONGE 
    4643      localviscsponge => wrk_2d_1 
    47       tbdiff => wrk_3d_1 ;sbdiff => wrk_3d_2 
    48       ztu => wrk_3d_3 ; zsu => wrk_3d_4 
    49       ztv => wrk_3d_7 ; zsv => wrk_3d_6 
    50       ztab => wrk_3d_8 
     44      ztu             => wrk_2d_2 
     45      ztv             => wrk_2d_3 
     46      ztab            => wrk_4d_1 
     47      tsbdiff         => wrk_4d_2 
    5148 
    5249      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
     
    5552      Agrif_UseSpecialValue = .TRUE. 
    5653      ztab = 0.e0 
    57       CALL Agrif_Bc_Variable(ztab, ta_id,calledweight=timecoeff,procname=interptn) 
     54      CALL Agrif_Bc_Variable(ztab, tsa_id,calledweight=timecoeff,procname=interptsn) 
    5855      Agrif_UseSpecialValue = .FALSE. 
    5956 
    60       tbdiff(:,:,:) = tb(:,:,:) - ztab(:,:,:) 
    61  
    62       ztab = 0.e0 
    63       Agrif_SpecialValue=0. 
    64       Agrif_UseSpecialValue = .TRUE. 
    65       CALL Agrif_Bc_Variable(ztab, sa_id,calledweight=timecoeff,procname=interpsn) 
    66       Agrif_UseSpecialValue = .FALSE. 
    67  
    68       sbdiff(:,:,:) = sb(:,:,:) - ztab(:,:,:) 
     57      tsbdiff(:,:,:,:) = tsb(:,:,:,:) - ztab(:,:,:,:) 
    6958 
    7059      spongearea = 2 + 2 * Agrif_irhox() 
     
    137126      ENDIF 
    138127 
    139       DO jk = 1, jpkm1 
    140          DO jj = 1, jpjm1 
    141             DO ji = 1, jpim1 
    142                zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
    143                zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
    144                ztu(ji,jj,jk) = zabe1 * ( tbdiff(ji+1,jj  ,jk) - tbdiff(ji,jj,jk) ) 
    145                zsu(ji,jj,jk) = zabe1 * ( sbdiff(ji+1,jj  ,jk) - sbdiff(ji,jj,jk) ) 
    146                ztv(ji,jj,jk) = zabe2 * ( tbdiff(ji  ,jj+1,jk) - tbdiff(ji,jj,jk) ) 
    147                zsv(ji,jj,jk) = zabe2 * ( sbdiff(ji  ,jj+1,jk) - sbdiff(ji,jj,jk) ) 
     128      DO jn = 1, jpts 
     129         DO jk = 1, jpkm1 
     130            ! 
     131            DO jj = 1, jpjm1 
     132               DO ji = 1, jpim1 
     133                  zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
     134                  zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
     135                  ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
     136                  ztv(ji,jj) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
     137               ENDDO 
    148138            ENDDO 
    149          ENDDO 
    150  
    151          DO jj = 2,jpjm1 
    152             DO ji = 2,jpim1 
    153                zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    154                ! horizontal diffusive trends 
    155                zta = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)   & 
    156                   &          + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) 
    157                zsa = zbtr * (  zsu(ji,jj,jk) - zsu(ji-1,jj,jk)   & 
    158                   &          + zsv(ji,jj,jk) - zsv(ji,jj-1,jk)  ) 
    159                ! add it to the general tracer trends 
    160                ta(ji,jj,jk) = (ta(ji,jj,jk) + zta) 
    161                sa(ji,jj,jk) = (sa(ji,jj,jk) + zsa) 
     139 
     140            DO jj = 2, jpjm1 
     141               DO ji = 2, jpim1 
     142                  zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
     143                  ! horizontal diffusive trends 
     144                  ztsa = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  )   & 
     145                  &              + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
     146                  ! add it to the general tracer trends 
     147                  tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
     148               END DO 
    162149            END DO 
    163          END DO 
    164  
     150            ! 
     151         ENDDO 
    165152      ENDDO 
    166153 
     
    345332   END SUBROUTINE Agrif_Sponge_dyn 
    346333 
    347    SUBROUTINE interptn(tabres,i1,i2,j1,j2,k1,k2) 
    348       !!--------------------------------------------- 
    349       !!   *** ROUTINE interptn *** 
     334   SUBROUTINE interptsn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
     335      !!--------------------------------------------- 
     336      !!   *** ROUTINE interptsn *** 
    350337      !!--------------------------------------------- 
    351338#  include "domzgr_substitute.h90"        
    352339       
    353       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    354       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    355  
    356       tabres(i1:i2,j1:j2,k1:k2) = tn(i1:i2,j1:j2,k1:k2) 
    357  
    358    END SUBROUTINE interptn 
    359  
    360    SUBROUTINE interpsn(tabres,i1,i2,j1,j2,k1,k2) 
    361       !!--------------------------------------------- 
    362       !!   *** ROUTINE interpsn *** 
    363       !!--------------------------------------------- 
    364 #  include "domzgr_substitute.h90"        
    365        
    366       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    367       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    368  
    369       tabres(i1:i2,j1:j2,k1:k2) = sn(i1:i2,j1:j2,k1:k2) 
    370  
    371    END SUBROUTINE interpsn 
     340      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     341      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     342 
     343      tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     344 
     345   END SUBROUTINE interptsn 
    372346 
    373347   SUBROUTINE interpun(tabres,i1,i2,j1,j2,k1,k2) 
  • branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r2715 r2789  
    3030      !!--------------------------------------------- 
    3131      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    32       USE wrk_nemo, ONLY: wrk_3d_1 
     32      USE wrk_nemo, ONLY: wrk_4d_1 
    3333      !! 
    3434      INTEGER, INTENT(in) :: kt 
    35       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
     35      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    3636 
    3737        
    3838      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
    3939#if defined TWO_WAY 
    40       ztab => wrk_3d_1 
    41       IF( wrk_in_use(3, 1) ) THEN 
     40      IF( wrk_in_use(4, 1) ) THEN 
    4241         CALL ctl_stop('agrif_update_tra: ERROR: requested workspace arrays unavailable') 
    4342         RETURN 
    4443      END IF 
     44      ztab => wrk_4d_1 
    4545 
    4646      Agrif_UseSpecialValueInUpdate = .TRUE. 
     
    4848 
    4949      IF (MOD(nbcline,nbclineupdate) == 0) THEN 
    50          CALL Agrif_Update_Variable(ztab,tn_id, procname=updateT) 
    51          CALL Agrif_Update_Variable(ztab,sn_id, procname=updateS) 
    52       ELSE 
    53          CALL Agrif_Update_Variable(ztab,tn_id,locupdate=(/0,2/), procname=updateT) 
    54          CALL Agrif_Update_Variable(ztab,sn_id,locupdate=(/0,2/), procname=updateS) 
     50         CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 
     51      ELSE 
     52         CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 
    5553      ENDIF 
    5654 
    5755      Agrif_UseSpecialValueInUpdate = .FALSE. 
    5856 
    59       IF( wrk_not_released(3, 1) ) THEN 
     57      IF( wrk_not_released(4, 1) ) THEN 
    6058         CALL ctl_stop('Agrif_Update_Tra: ERROR: failed to release workspace arrays') 
    6159      END IF 
     
    124122   END SUBROUTINE recompute_diags 
    125123 
    126    SUBROUTINE updateT( tabres, i1, i2, j1, j2, k1, k2, before ) 
     124   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    127125      !!--------------------------------------------- 
    128126      !!           *** ROUTINE updateT *** 
     
    130128#  include "domzgr_substitute.h90" 
    131129 
    132       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    133       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     130      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     131      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    134132      LOGICAL, iNTENT(in) :: before 
    135133 
    136       INTEGER :: ji,jj,jk 
    137  
    138       IF (before) THEN 
    139          DO jk=k1,k2 
    140             DO jj=j1,j2 
    141                DO ji=i1,i2 
    142                   tabres(ji,jj,jk) = tn(ji,jj,jk) 
    143                END DO 
    144             END DO 
    145          END DO 
    146       ELSE 
    147          DO jk=k1,k2 
    148             DO jj=j1,j2 
    149                DO ji=i1,i2 
    150                   IF( tabres(ji,jj,jk) .NE. 0. ) THEN 
    151                      tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 
    152                   ENDIF 
    153                END DO 
    154             END DO 
    155          END DO 
    156       ENDIF 
    157  
    158    END SUBROUTINE updateT 
    159  
    160    SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before ) 
    161       !!--------------------------------------------- 
    162       !!           *** ROUTINE updateS *** 
    163       !!--------------------------------------------- 
    164 #  include "domzgr_substitute.h90" 
    165  
    166       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    167       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    168       LOGICAL, iNTENT(in) :: before 
    169  
    170       INTEGER :: ji,jj,jk 
    171  
    172       IF (before) THEN 
    173          DO jk=k1,k2 
    174             DO jj=j1,j2 
    175                DO ji=i1,i2 
    176                   tabres(ji,jj,jk) = sn(ji,jj,jk) 
    177                END DO 
    178             END DO 
    179          END DO 
    180       ELSE 
    181          DO jk=k1,k2 
    182             DO jj=j1,j2 
    183                DO ji=i1,i2 
    184                   IF (tabres(ji,jj,jk).NE.0.) THEN 
    185                      sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 
    186                   ENDIF 
    187                END DO 
    188             END DO 
    189          END DO 
    190       ENDIF 
    191  
    192    END SUBROUTINE updateS 
     134      INTEGER :: ji,jj,jk,jn 
     135 
     136      IF (before) THEN 
     137         DO jn = n1,n2 
     138            DO jk=k1,k2 
     139               DO jj=j1,j2 
     140                  DO ji=i1,i2 
     141                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) 
     142                  END DO 
     143               END DO 
     144            END DO 
     145         END DO 
     146      ELSE 
     147         DO jn = n1,n2 
     148            DO jk=k1,k2 
     149               DO jj=j1,j2 
     150                  DO ji=i1,i2 
     151                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN  
     152                         tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     153                     END IF 
     154                  END DO 
     155               END DO 
     156            END DO 
     157         END DO 
     158      ENDIF 
     159 
     160   END SUBROUTINE updateTS 
    193161 
    194162   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before ) 
  • branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r2727 r2789  
    5454      USE dom_oce 
    5555      USE nemogcm 
    56 #if defined key_tradmp   ||   defined key_esopa 
    5756      USE tradmp 
    58 #endif 
    5957#if defined key_obc   ||   defined key_esopa 
    6058      USE obc_par 
     
    7169 
    7270      ! Specific fine grid Initializations 
    73 #if defined key_tradmp || defined key_esopa 
    7471      ! no tracer damping on fine grids 
    75       lk_tradmp = .FALSE. 
    76 #endif 
     72      ln_tradmp = .FALSE. 
    7773#if defined key_obc || defined key_esopa 
    7874      ! no open boundary on fine grids 
     
    110106      IMPLICIT NONE 
    111107      ! 
    112       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tabtemp 
     108      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 
     109      REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE :: tabuvtemp 
    113110      LOGICAL :: check_namelist 
    114111      !!---------------------------------------------------------------------- 
    115112 
    116       ALLOCATE( tabtemp(jpi,jpj,jpk) ) 
    117        
    118        
     113      ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 
     114      ALLOCATE( tabuvtemp(jpi, jpj, jpk)       ) 
     115 
     116 
    119117      ! 1. Declaration of the type of variable which have to be interpolated 
    120118      !--------------------------------------------------------------------- 
     
    125123      Agrif_SpecialValue=0. 
    126124      Agrif_UseSpecialValue = .TRUE. 
    127       Call Agrif_Bc_variable(tabtemp,tn_id,calledweight=1.,procname=interptn) 
    128      
    129       Call Agrif_Bc_variable(tabtemp,sn_id,calledweight=1.,procname=interpsn) 
    130       Call Agrif_Bc_variable(tabtemp,un_id,calledweight=1.,procname=interpu) 
    131       Call Agrif_Bc_variable(tabtemp,vn_id,calledweight=1.,procname=interpv) 
    132  
    133       Call Agrif_Bc_variable(tabtemp,ta_id,calledweight=1.,procname=interptn) 
    134       Call Agrif_Bc_variable(tabtemp,sa_id,calledweight=1.,procname=interpsn) 
    135  
    136       Call Agrif_Bc_variable(tabtemp,ua_id,calledweight=1.,procname=interpun) 
    137       Call Agrif_Bc_variable(tabtemp,va_id,calledweight=1.,procname=interpvn) 
     125      Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 
     126      Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 
     127 
     128      Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 
     129      Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 
     130      Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 
     131      Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 
    138132      Agrif_UseSpecialValue = .FALSE. 
    139133 
     
    192186      nbcline = 0 
    193187      ! 
    194       DEALLOCATE(tabtemp) 
     188      DEALLOCATE(tabtstemp) 
     189      DEALLOCATE(tabuvtemp) 
    195190      ! 
    196191   END SUBROUTINE Agrif_InitValues_cont 
     
    204199      !!---------------------------------------------------------------------- 
    205200      USE agrif_util 
     201      USE par_oce       !   ONLY : jpts 
    206202      USE oce 
    207203      IMPLICIT NONE 
     
    210206      ! 1. Declaration of the type of variable which have to be interpolated 
    211207      !--------------------------------------------------------------------- 
    212       CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),tn_id) 
    213       CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),sn_id) 
    214       CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),tb_id) 
    215       CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),sb_id) 
    216       CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ta_id) 
    217       CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),sa_id) 
    218           
     208      CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 
     209      CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 
     210      CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 
     211 
    219212      CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 
    220213      CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 
     
    230223      ! 2. Type of interpolation 
    231224      !------------------------- 
    232       CALL Agrif_Set_bcinterp(tn_id,interp=AGRIF_linear) 
    233       CALL Agrif_Set_bcinterp(sn_id,interp=AGRIF_linear) 
    234       CALL Agrif_Set_bcinterp(ta_id,interp=AGRIF_linear) 
    235       CALL Agrif_Set_bcinterp(sa_id,interp=AGRIF_linear) 
     225      CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
     226      CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 
    236227    
    237228      Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     
    252243      Call Agrif_Set_bc(e2v_id,(/0,0/)) 
    253244 
    254       Call Agrif_Set_bc(tn_id,(/0,1/)) 
    255       Call Agrif_Set_bc(sn_id,(/0,1/)) 
    256  
    257       Call Agrif_Set_bc(ta_id,(/-3*Agrif_irhox(),0/)) 
    258       Call Agrif_Set_bc(sa_id,(/-3*Agrif_irhox(),0/)) 
     245      Call Agrif_Set_bc(tsn_id,(/0,1/)) 
     246      Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 
    259247 
    260248      Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 
     
    263251      ! 5. Update type 
    264252      !---------------  
    265       Call Agrif_Set_Updatetype(tn_id, update = AGRIF_Update_Average) 
    266       Call Agrif_Set_Updatetype(sn_id, update = AGRIF_Update_Average) 
    267  
    268       Call Agrif_Set_Updatetype(tb_id, update = AGRIF_Update_Average) 
    269       Call Agrif_Set_Updatetype(sb_id, update = AGRIF_Update_Average) 
     253      Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
     254      Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 
    270255 
    271256      Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
     
    395380      ! 1. Declaration of the type of variable which have to be interpolated 
    396381      !--------------------------------------------------------------------- 
    397       CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),  & 
    398       &                           (/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 
    399       CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),  & 
    400       &                           (/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 
    401       CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0,jptra/),(/'x','y','N','N'/),  & 
    402       &                           (/1,1,1,1/),(/jpi,jpj,jpk/),tra_id) 
    403              
     382      CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 
     383      CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 
     384      CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 
    404385#  if defined key_offline 
    405386      CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
Note: See TracChangeset for help on using the changeset viewer.