- Timestamp:
- 2018-10-29T15:20:26+01:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_AMM15_package/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
r10248 r10251 7 7 USE agrif_oce 8 8 USE agrif_top_sponge 9 USE par_trc10 9 USE trc 11 10 USE lib_mpp … … 15 14 PRIVATE 16 15 17 PUBLIC Agrif_trc , interptrn16 PUBLIC Agrif_trc 18 17 19 18 # include "domzgr_substitute.h90" 20 19 # include "vectopt_loop_substitute.h90" 21 20 !!---------------------------------------------------------------------- 22 !! NEMO/NST 3. 6, NEMO Consortium (2010)21 !! NEMO/NST 3.3 , NEMO Consortium (2010) 23 22 !! $Id$ 24 23 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 29 28 SUBROUTINE Agrif_trc 30 29 !!---------------------------------------------------------------------- 31 !! *** ROUTINE Agrif_trc *** 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 32 37 !!---------------------------------------------------------------------- 33 38 ! 34 39 IF( Agrif_Root() ) RETURN 35 40 41 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 42 36 43 Agrif_SpecialValue = 0.e0 37 44 Agrif_UseSpecialValue = .TRUE. 45 ztra(:,:,:,:) = 0.e0 38 46 39 CALL Agrif_Bc_variable( trn_id, procname=interptrn )47 CALL Agrif_Bc_variable( ztra, trn_id, procname=interptrn ) 40 48 Agrif_UseSpecialValue = .FALSE. 41 !42 END SUBROUTINE Agrif_trc43 49 44 SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 45 !!--------------------------------------------- 46 !! *** ROUTINE interptrn *** 47 !!--------------------------------------------- 48 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 49 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 50 LOGICAL, INTENT(in) :: before 51 INTEGER, INTENT(in) :: nb , ndir 52 ! 53 INTEGER :: ji, jj, jk, jn ! dummy loop indices 54 INTEGER :: imin, imax, jmin, jmax 55 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 56 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 57 LOGICAL :: western_side, eastern_side,northern_side,southern_side 50 zrhox = Agrif_Rhox() 58 51 59 IF (before) THEN 60 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 61 ELSE 62 ! 63 western_side = (nb == 1).AND.(ndir == 1) 64 eastern_side = (nb == 1).AND.(ndir == 2) 65 southern_side = (nb == 2).AND.(ndir == 1) 66 northern_side = (nb == 2).AND.(ndir == 2) 67 ! 68 zrhox = Agrif_Rhox() 69 ! 70 zalpha1 = ( zrhox - 1. ) * 0.5 71 zalpha2 = 1. - zalpha1 72 ! 73 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 74 zalpha4 = 1. - zalpha3 75 ! 76 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 77 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 78 zalpha5 = 1. - zalpha6 - zalpha7 79 ! 80 imin = i1 81 imax = i2 82 jmin = j1 83 jmax = j2 84 ! 85 ! Remove CORNERS 86 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 87 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 88 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 89 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 90 ! 91 IF( eastern_side) THEN 92 DO jn = 1, jptra 93 tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 94 DO jk = 1, jpkm1 95 DO jj = jmin,jmax 96 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 97 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 98 ELSE 99 tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 100 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 101 tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) & 102 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 103 ENDIF 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) 104 74 ENDIF 105 END DO 106 END DO 107 ENDDO 108 ENDIF 109 ! 110 IF( northern_side ) THEN 111 DO jn = 1, jptra 112 tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 113 DO jk = 1, jpkm1 114 DO ji = imin,imax 115 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 116 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 117 ELSE 118 tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 119 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 120 tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn) & 121 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 122 ENDIF 123 ENDIF 124 END DO 125 END DO 126 ENDDO 127 ENDIF 128 ! 129 IF( western_side) THEN 130 DO jn = 1, jptra 131 tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 132 DO jk = 1, jpkm1 133 DO jj = jmin,jmax 134 IF( umask(2,jj,jk) == 0.e0 ) THEN 135 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 136 ELSE 137 tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 138 IF( un(2,jj,jk) < 0.e0 ) THEN 139 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) 140 ENDIF 141 ENDIF 142 END DO 75 ENDIF 143 76 END DO 144 77 END DO 145 ENDIF 146 ! 147 IF( southern_side ) THEN 148 DO jn = 1, jptra 149 tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 150 DO jk=1,jpk 151 DO ji=imin,imax 152 IF( vmask(ji,2,jk) == 0.e0 ) THEN 153 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 154 ELSE 155 tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 156 IF( vn(ji,2,jk) < 0.e0 ) THEN 157 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) 158 ENDIF 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) 159 94 ENDIF 160 END DO95 ENDIF 161 96 END DO 162 ENDDO 163 ENDIF 164 ! 165 ! Treatment of corners 166 ! 167 ! East south 168 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 169 tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 170 ENDIF 171 ! East north 172 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 173 tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 174 ENDIF 175 ! West south 176 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 177 tra(2,2,:,:) = ptab(2,2,:,:) 178 ENDIF 179 ! West north 180 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 181 tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 182 ENDIF 183 ! 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 184 134 ENDIF 185 135 ! 186 END SUBROUTINE interptrn 136 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 137 ! 138 139 END SUBROUTINE Agrif_trc 187 140 188 141 #else
Note: See TracChangeset
for help on using the changeset viewer.
