Changeset 5951 for branches/2014/dev_r4650_UKMO14.4_OBS_GENERAL_VINTERP/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
- Timestamp:
- 2015-11-30T12:48:01+01:00 (8 years ago)
- 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 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 18 # include "domzgr_substitute.h90" 19 19 # include "vectopt_loop_substitute.h90" 20 20 !!---------------------------------------------------------------------- 21 !! NEMO/NST 3. 3, NEMO Consortium (2010)21 !! NEMO/NST 3.6 , NEMO Consortium (2010) 22 22 !! $Id$ 23 23 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 28 28 SUBROUTINE Agrif_trc 29 29 !!---------------------------------------------------------------------- 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 *** 37 31 !!---------------------------------------------------------------------- 38 32 ! 39 33 IF( Agrif_Root() ) RETURN 40 34 41 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra )42 43 35 Agrif_SpecialValue = 0.e0 44 36 Agrif_UseSpecialValue = .TRUE. 45 ztra(:,:,:,:) = 0.e046 37 47 CALL Agrif_Bc_variable( ztra,trn_id, procname=interptrn )38 CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 48 39 Agrif_UseSpecialValue = .FALSE. 40 ! 41 END SUBROUTINE Agrif_trc 49 42 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 51 57 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 74 103 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 76 142 END DO 77 143 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 94 158 ENDIF 95 END IF159 END DO 96 160 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 ! 134 183 ENDIF 135 184 ! 136 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 137 ! 138 139 END SUBROUTINE Agrif_trc 185 END SUBROUTINE interptrn 140 186 141 187 #else
Note: See TracChangeset
for help on using the changeset viewer.