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 8882 for branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90 – NEMO

Ignore:
Timestamp:
2017-12-01T18:44:09+01:00 (6 years ago)
Author:
flavoni
Message:

dev_CNRS_2017 branch: merged dev_r7881_ENHANCE09_RK3 with trunk r8864

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

    r6140 r8882  
    11MODULE agrif_top_interp 
     2   !!====================================================================== 
     3   !!                   ***  MODULE  agrif_top_interp  *** 
     4   !! AGRIF: interpolation package for TOP 
     5   !!====================================================================== 
     6   !! History :  2.0  !  ???  
     7   !!---------------------------------------------------------------------- 
    28#if defined key_agrif && defined key_top 
     9   !!---------------------------------------------------------------------- 
     10   !!   'key_agrif'                                              AGRIF zoom 
     11   !!   'key_top'                                           on-line tracers 
     12   !!---------------------------------------------------------------------- 
    313   USE par_oce 
    414   USE oce 
     
    818   USE par_trc 
    919   USE trc 
    10    USE lib_mpp 
    11    USE wrk_nemo   
     20   ! 
     21   USE lib_mpp     ! MPP library 
    1222 
    1323   IMPLICIT NONE 
     
    1626   PUBLIC Agrif_trc, interptrn 
    1727 
    18 #  include "vectopt_loop_substitute.h90" 
    1928  !!---------------------------------------------------------------------- 
    20    !! NEMO/NST 3.6 , NEMO Consortium (2010) 
     29   !! NEMO/NST 4.0 , NEMO Consortium (2017) 
    2130   !! $Id$ 
    2231   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     
    2635   SUBROUTINE Agrif_trc 
    2736      !!---------------------------------------------------------------------- 
    28       !!                  ***  ROUTINE Agrif_trc  *** 
     37      !!                   ***  ROUTINE Agrif_trc  *** 
    2938      !!---------------------------------------------------------------------- 
    3039      ! 
    3140      IF( Agrif_Root() )   RETURN 
    32  
    33       Agrif_SpecialValue    = 0.e0 
     41      ! 
     42      Agrif_SpecialValue    = 0._wp 
    3443      Agrif_UseSpecialValue = .TRUE. 
    35  
     44      ! 
    3645      CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 
    3746      Agrif_UseSpecialValue = .FALSE. 
     
    4049 
    4150 
    42    SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
    43       !!--------------------------------------------- 
    44       !!   *** ROUTINE interptrn *** 
    45       !!--------------------------------------------- 
    46       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
    47       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    48       LOGICAL, INTENT(in) :: before 
    49       INTEGER, INTENT(in) :: nb , ndir 
     51   SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 
     52      !!---------------------------------------------------------------------- 
     53      !!                   *** ROUTINE interptrn *** 
     54      !!---------------------------------------------------------------------- 
     55      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab 
     56      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2 
     57      LOGICAL                                     , INTENT(in   ) ::   before 
     58      INTEGER                                     , INTENT(in   ) ::   nb , ndir 
     59      !! 
     60      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
     61      INTEGER ::   imin, imax, jmin, jmax 
     62      LOGICAL ::   ll_west, ll_east, ll_north, ll_south 
     63      REAL(wp) ::   zrhox, z1, z2, z3, z4, z5, z6, z7 
     64      !!---------------------------------------------------------------------- 
    5065      ! 
    51       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    52       INTEGER :: imin, imax, jmin, jmax 
    53       REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
    54       REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
    55       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    56  
    57       IF (before) THEN          
     66      IF( before ) THEN          
    5867         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
    5968      ELSE 
    6069         ! 
    61          western_side  = (nb == 1).AND.(ndir == 1) 
    62          eastern_side  = (nb == 1).AND.(ndir == 2) 
    63          southern_side = (nb == 2).AND.(ndir == 1) 
    64          northern_side = (nb == 2).AND.(ndir == 2) 
    65          ! 
    66          zrhox = Agrif_Rhox() 
    67          !  
    68          zalpha1 = ( zrhox - 1. ) * 0.5 
    69          zalpha2 = 1. - zalpha1 
    70          !  
    71          zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    72          zalpha4 = 1. - zalpha3 
    73          !  
    74          zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    75          zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    76          zalpha5 = 1. - zalpha6 - zalpha7 
    77          ! 
    78          imin = i1 
    79          imax = i2 
    80          jmin = j1 
    81          jmax = j2 
    82          !  
    83          ! Remove CORNERS 
    84          IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
    85          IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
    86          IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
    87          IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
    88          ! 
    89          IF( eastern_side) THEN 
    90             DO jn = 1, jptra 
    91                tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
    92                DO jk = 1, jpkm1 
    93                   DO jj = jmin,jmax 
    94                      IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    95                         tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    96                      ELSE 
    97                         tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    98                         IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    99                            tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) &  
    100                                  + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     70         IF( nbghostcells > 1 ) THEN  ! no smoothing 
     71            tra(i1:i2,j1:j2,k1:k2,n1:n2) = ptab(i1:i2,j1:j2,k1:k2,n1:n2) 
     72         ELSE                         ! smoothing 
     73            ! 
     74            ll_west  = (nb == 1).AND.(ndir == 1)   ;   ll_east  = (nb == 1).AND.(ndir == 2) 
     75            ll_south = (nb == 2).AND.(ndir == 1)   ;   ll_north = (nb == 2).AND.(ndir == 2) 
     76            ! 
     77            zrhox = Agrif_Rhox() 
     78            z1 = ( zrhox - 1. ) * 0.5 
     79            z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     80            z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     81            z7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     82            ! 
     83            z2 = 1. - z1 
     84            z4 = 1. - z3 
     85            z5 = 1. - z6 - z7 
     86            ! 
     87            imin = i1   ;   imax = i2 
     88            jmin = j1   ;   jmax = j2 
     89            !  
     90            ! Remove CORNERS 
     91            IF((nbondj == -1).OR.(nbondj == 2))   jmin = 3 
     92            IF((nbondj == +1).OR.(nbondj == 2))   jmax = nlcj-2 
     93            IF((nbondi == -1).OR.(nbondi == 2))   imin = 3 
     94            IF((nbondi == +1).OR.(nbondi == 2))   imax = nlci-2         
     95            ! 
     96            IF( ll_east ) THEN       !== eastern side  ==! 
     97               DO jn = 1, jptra 
     98                  tra(nlci,j1:j2,k1:k2,jn) = z1 * ptab(nlci,j1:j2,k1:k2,jn) + z2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     99                  DO jk = 1, jpkm1 
     100                     DO jj = jmin,jmax 
     101                        IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 
     102                           tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     103                        ELSE 
     104                           tra(nlci-1,jj,jk,jn) = ( z4*tra(nlci,jj,jk,jn)+z3*tra(nlci-2,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     105                           IF( un(nlci-2,jj,jk) > 0._wp ) THEN 
     106                              tra(nlci-1,jj,jk,jn) = ( z6*tra(nlci-2,jj,jk,jn)+z5*tra(nlci,jj,jk,jn)   &  
     107                                 &                    +z7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     108                           ENDIF 
    101109                        ENDIF 
    102                      ENDIF 
     110                     END DO 
     111                  END DO 
     112               ENDDO 
     113            ENDIF 
     114            !  
     115            IF( ll_north ) THEN        !==  northern side  ==! 
     116               DO jn = 1, jptra 
     117                  tra(i1:i2,nlcj,k1:k2,jn) = z1 * ptab(i1:i2,nlcj,k1:k2,jn) + z2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     118                  DO jk = 1, jpkm1 
     119                     DO ji = imin, imax 
     120                        IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN 
     121                           tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     122                        ELSE 
     123                           tra(ji,nlcj-1,jk,jn) = ( z4*tra(ji,nlcj,jk,jn)+z3*tra(ji,nlcj-2,jk,jn) ) * tmask(ji,nlcj-1,jk)         
     124                           IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 
     125                              tra(ji,nlcj-1,jk,jn) = ( z6*tra(ji,nlcj-2,jk,jn)+z5*tra(ji,nlcj,jk,jn)  & 
     126                                 &                    +z7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     127                           ENDIF 
     128                        ENDIF 
     129                     END DO 
    103130                  END DO 
    104131               END DO 
    105             ENDDO 
    106          ENDIF 
    107          !  
    108          IF( northern_side ) THEN             
    109             DO jn = 1, jptra 
    110                tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
    111                DO jk = 1, jpkm1 
    112                   DO ji = imin,imax 
    113                      IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    114                         tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    115                      ELSE 
    116                         tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
    117                         IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    118                            tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn)  & 
    119                                  + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     132            ENDIF 
     133            ! 
     134            IF( ll_west ) THEN         !==  western side  ==!           
     135               DO jn = 1, jptra 
     136                  tra(1,j1:j2,k1:k2,jn) = z1 * ptab(1,j1:j2,k1:k2,jn) + z2 * ptab(2,j1:j2,k1:k2,jn) 
     137                  DO jk = 1, jpkm1 
     138                     DO jj = jmin,jmax 
     139                        IF( umask(2,jj,jk) == 0._wp ) THEN 
     140                           tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
     141                        ELSE 
     142                           tra(2,jj,jk,jn) = ( z4*tra(1,jj,jk,jn)+z3*tra(3,jj,jk,jn) ) * tmask(2,jj,jk)         
     143                           IF( un(2,jj,jk) < 0._wp ) THEN 
     144                              tra(2,jj,jk,jn) = ( z6*tra(3,jj,jk,jn)+z5*tra(1,jj,jk,jn)+z7*tra(4,jj,jk,jn) ) * tmask(2,jj,jk) 
     145                           ENDIF 
    120146                        ENDIF 
    121                      ENDIF 
     147                     END DO 
    122148                  END DO 
    123149               END DO 
    124             ENDDO 
    125          ENDIF 
    126          ! 
    127          IF( western_side) THEN             
    128             DO jn = 1, jptra 
    129                tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
    130                DO jk = 1, jpkm1 
    131                   DO jj = jmin,jmax 
    132                      IF( umask(2,jj,jk) == 0.e0 ) THEN 
    133                         tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
    134                      ELSE 
    135                         tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)         
    136                         IF( un(2,jj,jk) < 0.e0 ) THEN 
    137                            tra(2,jj,jk,jn)=(zalpha6*tra(3,jj,jk,jn)+zalpha5*tra(1,jj,jk,jn)+zalpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
     150            ENDIF 
     151            ! 
     152            IF( ll_south ) THEN        !==  southern side  ==! 
     153               DO jn = 1, jptra 
     154                  tra(i1:i2,1,k1:k2,jn) = z1 * ptab(i1:i2,1,k1:k2,jn) + z2 * ptab(i1:i2,2,k1:k2,jn) 
     155                  DO jk = 1, jpk       
     156                     DO ji = imin, imax 
     157                        IF( vmask(ji,2,jk) == 0._wp ) THEN 
     158                           tra(ji,2,jk,jn) = tra(ji,1,jk,jn) * tmask(ji,2,jk) 
     159                        ELSE 
     160                           tra(ji,2,jk,jn) = ( z4*tra(ji,1,jk,jn)+z3*tra(ji,3,jk,jn) ) * tmask(ji,2,jk) 
     161                           IF( vn(ji,2,jk) < 0._wp ) THEN 
     162                              tra(ji,2,jk,jn) = ( z6*tra(ji,3,jk,jn)+z5*tra(ji,1,jk,jn)+z7*tra(ji,4,jk,jn) ) * tmask(ji,2,jk) 
     163                           ENDIF 
    138164                        ENDIF 
    139                      ENDIF 
     165                     END DO 
    140166                  END DO 
    141167               END DO 
    142             END DO 
     168            ENDIF 
     169            ! 
     170            ! Treatment of corners 
     171            IF( ll_east .AND.((nbondj == -1).OR.(nbondj == 2)) )   tra(nlci-1,   2  ,:,:) = ptab(nlci-1,   2  ,:,:)   ! East south 
     172            IF( ll_east .AND.((nbondj ==  1).OR.(nbondj == 2)) )   tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)   ! East north 
     173            IF( ll_west .AND.((nbondj == -1).OR.(nbondj == 2)) )   tra(   2  ,   2  ,:,:) = ptab(   2  ,   2  ,:,:)   ! West south 
     174            IF( ll_west .AND.((nbondj ==  1).OR.(nbondj == 2)) )   tra(   2  ,nlcj-1,:,:) = ptab(   2  ,nlcj-1,:,:)   ! West north 
     175            ! 
    143176         ENDIF 
    144          ! 
    145          IF( southern_side ) THEN            
    146             DO jn = 1, jptra 
    147                tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
    148                DO jk=1,jpk       
    149                   DO ji=imin,imax 
    150                      IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    151                         tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
    152                      ELSE 
    153                         tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
    154                         IF( vn(ji,2,jk) < 0.e0 ) THEN 
    155                            tra(ji,2,jk,jn)=(zalpha6*tra(ji,3,jk,jn)+zalpha5*tra(ji,1,jk,jn)+zalpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
    156                         ENDIF 
    157                      ENDIF 
    158                   END DO 
    159                END DO 
    160             ENDDO 
    161          ENDIF 
    162          ! 
    163          ! Treatment of corners 
    164          !  
    165          ! East south 
    166          IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    167             tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
    168          ENDIF 
    169          ! East north 
    170          IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    171             tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
    172          ENDIF 
    173          ! West south 
    174          IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    175             tra(2,2,:,:) = ptab(2,2,:,:) 
    176          ENDIF 
    177          ! West north 
    178          IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    179             tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
    180          ENDIF 
    181          ! 
    182177      ENDIF 
    183178      ! 
     
    185180 
    186181#else 
     182   !!---------------------------------------------------------------------- 
     183   !!   Empty module                                           no TOP AGRIF 
     184   !!---------------------------------------------------------------------- 
    187185CONTAINS 
    188186   SUBROUTINE Agrif_TOP_Interp_empty 
     
    193191   END SUBROUTINE Agrif_TOP_Interp_empty 
    194192#endif 
     193 
     194   !!====================================================================== 
    195195END MODULE agrif_top_interp 
Note: See TracChangeset for help on using the changeset viewer.