Changeset 6225 for branches/2014/dev_r4704_NOC5_MPP_BDY_UPDATE/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
- Timestamp:
- 2016-01-08T10:35:19+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4704_NOC5_MPP_BDY_UPDATE/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
r3680 r6225 4 4 USE oce 5 5 USE dom_oce 6 USE sol_oce7 6 USE agrif_oce 8 7 USE agrif_top_sponge 8 USE par_trc 9 9 USE trc 10 10 USE lib_mpp … … 14 14 PRIVATE 15 15 16 PUBLIC Agrif_trc 16 PUBLIC Agrif_trc, interptrn 17 17 18 # include "domzgr_substitute.h90"19 18 # include "vectopt_loop_substitute.h90" 20 19 !!---------------------------------------------------------------------- 21 !! NEMO/NST 3. 3, NEMO Consortium (2010)20 !! NEMO/NST 3.6 , NEMO Consortium (2010) 22 21 !! $Id$ 23 22 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 24 23 !!---------------------------------------------------------------------- 25 26 CONTAINS 24 CONTAINS 27 25 28 26 SUBROUTINE Agrif_trc 29 27 !!---------------------------------------------------------------------- 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 28 !! *** ROUTINE Agrif_trc *** 37 29 !!---------------------------------------------------------------------- 38 30 ! 39 31 IF( Agrif_Root() ) RETURN 40 32 41 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra )42 43 33 Agrif_SpecialValue = 0.e0 44 34 Agrif_UseSpecialValue = .TRUE. 45 ztra(:,:,:,:) = 0.e046 35 47 CALL Agrif_Bc_variable( ztra,trn_id, procname=interptrn )36 CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 48 37 Agrif_UseSpecialValue = .FALSE. 38 ! 39 END SUBROUTINE Agrif_trc 49 40 50 zrhox = Agrif_Rhox()51 41 52 alpha1 = ( zrhox - 1. ) * 0.5 53 alpha2 = 1. - alpha1 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 50 ! 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 54 56 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) 57 IF (before) THEN 58 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 59 ELSE 60 ! 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) 101 ENDIF 74 102 ENDIF 75 ENDIF 103 END DO 104 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) 120 ENDIF 121 ENDIF 122 END DO 123 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) 138 ENDIF 139 ENDIF 140 END DO 76 141 END DO 77 142 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) 143 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 94 157 ENDIF 95 END IF158 END DO 96 159 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 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 ! 134 182 ENDIF 135 183 ! 136 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 137 ! 138 139 END SUBROUTINE Agrif_trc 184 END SUBROUTINE interptrn 140 185 141 186 #else
Note: See TracChangeset
for help on using the changeset viewer.
