- Timestamp:
- 2017-12-01T18:44:09+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
r6140 r8882 1 1 MODULE agrif_top_interp 2 !!====================================================================== 3 !! *** MODULE agrif_top_interp *** 4 !! AGRIF: interpolation package for TOP 5 !!====================================================================== 6 !! History : 2.0 ! ??? 7 !!---------------------------------------------------------------------- 2 8 #if defined key_agrif && defined key_top 9 !!---------------------------------------------------------------------- 10 !! 'key_agrif' AGRIF zoom 11 !! 'key_top' on-line tracers 12 !!---------------------------------------------------------------------- 3 13 USE par_oce 4 14 USE oce … … 8 18 USE par_trc 9 19 USE trc 10 USE lib_mpp11 USE wrk_nemo20 ! 21 USE lib_mpp ! MPP library 12 22 13 23 IMPLICIT NONE … … 16 26 PUBLIC Agrif_trc, interptrn 17 27 18 # include "vectopt_loop_substitute.h90"19 28 !!---------------------------------------------------------------------- 20 !! NEMO/NST 3.6 , NEMO Consortium (2010)29 !! NEMO/NST 4.0 , NEMO Consortium (2017) 21 30 !! $Id$ 22 31 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 26 35 SUBROUTINE Agrif_trc 27 36 !!---------------------------------------------------------------------- 28 !! *** ROUTINE Agrif_trc ***37 !! *** ROUTINE Agrif_trc *** 29 38 !!---------------------------------------------------------------------- 30 39 ! 31 40 IF( Agrif_Root() ) RETURN 32 33 Agrif_SpecialValue = 0. e041 ! 42 Agrif_SpecialValue = 0._wp 34 43 Agrif_UseSpecialValue = .TRUE. 35 44 ! 36 45 CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 37 46 Agrif_UseSpecialValue = .FALSE. … … 40 49 41 50 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 !!---------------------------------------------------------------------- 50 65 ! 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 58 67 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 59 68 ELSE 60 69 ! 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 101 109 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 103 130 END DO 104 131 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 120 146 ENDIF 121 END IF147 END DO 122 148 END DO 123 149 END DO 124 END DO125 ENDIF126 !127 IF( western_side) THEN128 DO jn = 1, jptra129 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, jpkm1131 DO jj = jmin,jmax132 IF( umask(2,jj,jk) == 0.e0 ) THEN133 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk)134 ELSE135 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 ) THEN137 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 138 164 ENDIF 139 END IF165 END DO 140 166 END DO 141 167 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 ! 143 176 ENDIF 144 !145 IF( southern_side ) THEN146 DO jn = 1, jptra147 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,jpk149 DO ji=imin,imax150 IF( vmask(ji,2,jk) == 0.e0 ) THEN151 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk)152 ELSE153 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 ) THEN155 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 ENDIF157 ENDIF158 END DO159 END DO160 ENDDO161 ENDIF162 !163 ! Treatment of corners164 !165 ! East south166 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN167 tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)168 ENDIF169 ! East north170 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN171 tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)172 ENDIF173 ! West south174 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN175 tra(2,2,:,:) = ptab(2,2,:,:)176 ENDIF177 ! West north178 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN179 tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)180 ENDIF181 !182 177 ENDIF 183 178 ! … … 185 180 186 181 #else 182 !!---------------------------------------------------------------------- 183 !! Empty module no TOP AGRIF 184 !!---------------------------------------------------------------------- 187 185 CONTAINS 188 186 SUBROUTINE Agrif_TOP_Interp_empty … … 193 191 END SUBROUTINE Agrif_TOP_Interp_empty 194 192 #endif 193 194 !!====================================================================== 195 195 END MODULE agrif_top_interp
Note: See TracChangeset
for help on using the changeset viewer.