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 5951 for branches/2014/dev_r4650_UKMO14.4_OBS_GENERAL_VINTERP/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90 – NEMO

Ignore:
Timestamp:
2015-11-30T12:48:01+01:00 (8 years ago)
Author:
timgraham
Message:

Merged trunk r5936 into branch

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/2014/dev_r4650_UKMO14.4_OBS_GENERAL_VINTERP/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

    r5950 r5951  
    44   USE oce 
    55   USE dom_oce       
    6    USE sol_oce 
    76   USE agrif_oce 
    87   USE agrif_top_sponge 
     8   USE par_trc 
    99   USE trc 
    1010   USE lib_mpp 
     
    1414   PRIVATE 
    1515 
    16    PUBLIC Agrif_trc 
     16   PUBLIC Agrif_trc, interptrn 
    1717 
    1818#  include "domzgr_substitute.h90"   
    1919#  include "vectopt_loop_substitute.h90" 
    2020  !!---------------------------------------------------------------------- 
    21    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     21   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2222   !! $Id$ 
    2323   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     
    2828   SUBROUTINE Agrif_trc 
    2929      !!---------------------------------------------------------------------- 
    30       !!                  ***  ROUTINE Agrif_Tra  *** 
    31       !!---------------------------------------------------------------------- 
    32       !! 
    33       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    34       REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
    35       REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
    36       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 
     30      !!                  ***  ROUTINE Agrif_trc  *** 
    3731      !!---------------------------------------------------------------------- 
    3832      ! 
    3933      IF( Agrif_Root() )   RETURN 
    4034 
    41       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    42  
    4335      Agrif_SpecialValue    = 0.e0 
    4436      Agrif_UseSpecialValue = .TRUE. 
    45       ztra(:,:,:,:) = 0.e0 
    4637 
    47       CALL Agrif_Bc_variable( ztra, trn_id, procname=interptrn ) 
     38      CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 
    4839      Agrif_UseSpecialValue = .FALSE. 
     40      ! 
     41   END SUBROUTINE Agrif_trc 
    4942 
    50       zrhox = Agrif_Rhox() 
     43   SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
     44      !!--------------------------------------------- 
     45      !!   *** ROUTINE interptrn *** 
     46      !!--------------------------------------------- 
     47      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     48      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     49      LOGICAL, INTENT(in) :: before 
     50      INTEGER, INTENT(in) :: nb , ndir 
     51      ! 
     52      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     53      INTEGER :: imin, imax, jmin, jmax 
     54      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
     55      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     56      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    5157 
    52       alpha1 = ( zrhox - 1. ) * 0.5 
    53       alpha2 = 1. - alpha1 
    54  
    55       alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    56       alpha4 = 1. - alpha3 
    57  
    58       alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    59       alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    60       alpha5 = 1. - alpha6 - alpha7 
    61       IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    62  
    63          DO jn = 1, jptra 
    64             tra(nlci,:,:,jn) = alpha1 * ztra(nlci,:,:,jn) + alpha2 * ztra(nlci-1,:,:,jn) 
    65             DO jk = 1, jpkm1 
    66                DO jj = 1, jpj 
    67                   IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    68                      tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    69                   ELSE 
    70                      tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    71                      IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    72                         tra(nlci-1,jj,jk,jn)=( alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn)  & 
    73                            &                 + alpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     58      IF (before) THEN          
     59         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     60      ELSE 
     61         ! 
     62         western_side  = (nb == 1).AND.(ndir == 1) 
     63         eastern_side  = (nb == 1).AND.(ndir == 2) 
     64         southern_side = (nb == 2).AND.(ndir == 1) 
     65         northern_side = (nb == 2).AND.(ndir == 2) 
     66         ! 
     67         zrhox = Agrif_Rhox() 
     68         !  
     69         zalpha1 = ( zrhox - 1. ) * 0.5 
     70         zalpha2 = 1. - zalpha1 
     71         !  
     72         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     73         zalpha4 = 1. - zalpha3 
     74         !  
     75         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     76         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     77         zalpha5 = 1. - zalpha6 - zalpha7 
     78         ! 
     79         imin = i1 
     80         imax = i2 
     81         jmin = j1 
     82         jmax = j2 
     83         !  
     84         ! Remove CORNERS 
     85         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     86         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     87         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     88         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     89         ! 
     90         IF( eastern_side) THEN 
     91            DO jn = 1, jptra 
     92               tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     93               DO jk = 1, jpkm1 
     94                  DO jj = jmin,jmax 
     95                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     96                        tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     97                     ELSE 
     98                        tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     99                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     100                           tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) &  
     101                                 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     102                        ENDIF 
    74103                     ENDIF 
    75                   ENDIF 
     104                  END DO 
     105               END DO 
     106            ENDDO 
     107         ENDIF 
     108         !  
     109         IF( northern_side ) THEN             
     110            DO jn = 1, jptra 
     111               tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     112               DO jk = 1, jpkm1 
     113                  DO ji = imin,imax 
     114                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     115                        tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     116                     ELSE 
     117                        tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     118                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     119                           tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn)  & 
     120                                 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     121                        ENDIF 
     122                     ENDIF 
     123                  END DO 
     124               END DO 
     125            ENDDO 
     126         ENDIF 
     127         ! 
     128         IF( western_side) THEN             
     129            DO jn = 1, jptra 
     130               tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
     131               DO jk = 1, jpkm1 
     132                  DO jj = jmin,jmax 
     133                     IF( umask(2,jj,jk) == 0.e0 ) THEN 
     134                        tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
     135                     ELSE 
     136                        tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)         
     137                        IF( un(2,jj,jk) < 0.e0 ) THEN 
     138                           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) 
     139                        ENDIF 
     140                     ENDIF 
     141                  END DO 
    76142               END DO 
    77143            END DO 
    78          ENDDO 
    79       ENDIF 
    80  
    81       IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
    82  
    83          DO jn = 1, jptra 
    84             tra(:,nlcj,:,jn) = alpha1 * ztra(:,nlcj,:,jn) + alpha2 * ztra(:,nlcj-1,:,jn) 
    85             DO jk = 1, jpkm1 
    86                DO ji = 1, jpi 
    87                   IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    88                      tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    89                   ELSE 
    90                      tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 
    91                      IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    92                         tra(ji,nlcj-1,jk,jn)=( alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn)  & 
    93                            &                 + alpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     144         ENDIF 
     145         ! 
     146         IF( southern_side ) THEN            
     147            DO jn = 1, jptra 
     148               tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
     149               DO jk=1,jpk       
     150                  DO ji=imin,imax 
     151                     IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     152                        tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
     153                     ELSE 
     154                        tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
     155                        IF( vn(ji,2,jk) < 0.e0 ) THEN 
     156                           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) 
     157                        ENDIF 
    94158                     ENDIF 
    95                   ENDIF 
     159                  END DO 
    96160               END DO 
    97             END DO 
    98          ENDDO 
    99       ENDIF 
    100       IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    101          DO jn = 1, jptra 
    102             tra(1,:,:,jn) = alpha1 * ztra(1,:,:,jn) + alpha2 * ztra(2,:,:,jn) 
    103             DO jk = 1, jpkm1 
    104                DO jj = 1, jpj 
    105                   IF( umask(2,jj,jk) == 0.e0 ) THEN 
    106                      tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
    107                   ELSE 
    108                      tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 
    109                      IF( un(2,jj,jk) < 0.e0 ) THEN 
    110                         tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn)+alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
    111                      ENDIF 
    112                   ENDIF 
    113                END DO 
    114             END DO 
    115          END DO 
    116       ENDIF 
    117  
    118       IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    119          DO jn = 1, jptra 
    120             tra(:,1,:,jn) = alpha1 * ztra(:,1,:,jn) + alpha2 * ztra(:,2,:,jn) 
    121             DO jk=1,jpk 
    122                DO ji=1,jpi 
    123                   IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    124                      tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
    125                   ELSE 
    126                      tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
    127                      IF( vn(ji,2,jk) < 0.e0 ) THEN 
    128                         tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)+alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
    129                      ENDIF 
    130                   ENDIF 
    131                END DO 
    132             END DO 
    133          ENDDO 
     161            ENDDO 
     162         ENDIF 
     163         ! 
     164         ! Treatment of corners 
     165         !  
     166         ! East south 
     167         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     168            tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     169         ENDIF 
     170         ! East north 
     171         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     172            tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     173         ENDIF 
     174         ! West south 
     175         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     176            tra(2,2,:,:) = ptab(2,2,:,:) 
     177         ENDIF 
     178         ! West north 
     179         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     180            tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     181         ENDIF 
     182         ! 
    134183      ENDIF 
    135184      ! 
    136       CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    137       ! 
    138  
    139    END SUBROUTINE Agrif_trc 
     185   END SUBROUTINE interptrn 
    140186 
    141187#else 
Note: See TracChangeset for help on using the changeset viewer.