Changeset 636
- Timestamp:
- 2007-03-07T14:28:16+01:00 (17 years ago)
- Location:
- trunk/NEMO/NST_SRC
- Files:
-
- 6 edited
-
agrif_opa_interp.F90 (modified) (2 diffs)
-
agrif_opa_sponge.F90 (modified) (12 diffs)
-
agrif_opa_update.F90 (modified) (2 diffs)
-
agrif_top_interp.F90 (modified) (1 diff)
-
agrif_top_update.F90 (modified) (1 diff)
-
agrif_user.F90 (modified) (12 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/NST_SRC/agrif_opa_interp.F90
r469 r636 1 ! 2 Module agrif_opa_interp 1 MODULE agrif_opa_interp 3 2 #if defined key_agrif 4 USE par_oce 5 USE oce 6 USE dom_oce 7 USE sol_oce 8 9 CONTAINS 10 SUBROUTINE Agrif_tra( kt ) 11 12 Implicit none 13 14 !! * Substitutions 3 USE par_oce 4 USE oce 5 USE dom_oce 6 USE sol_oce 7 8 IMPLICIT NONE 9 PRIVATE 10 11 PUBLIC Agrif_tra, Agrif_dyn, interpu, interpv 12 13 CONTAINS 14 15 SUBROUTINE Agrif_tra( kt ) 16 !!--------------------------------------------- 17 !! *** ROUTINE Agrif_Tra *** 18 !!--------------------------------------------- 15 19 # include "domzgr_substitute.h90" 16 20 # include "vectopt_loop_substitute.h90" 17 ! 18 INTEGER :: kt19 REAL(wp) tatemp(jpi,jpj,jpk) , satemp(jpi,jpj,jpk) 21 22 INTEGER, INTENT(in) :: kt 23 20 24 INTEGER :: ji,jj,jk 21 REAL(wp) :: rhox25 REAL(wp) :: zrhox 22 26 REAL(wp) :: alpha1, alpha2, alpha3, alpha4 23 27 REAL(wp) :: alpha5, alpha6, alpha7 24 ! 25 IF (Agrif_Root()) RETURN 26 27 Agrif_SpecialValue=0. 28 Agrif_UseSpecialValue = .TRUE. 29 tatemp = 0. 30 satemp = 0. 31 32 Call Agrif_Bc_variable(tatemp,tn) 33 Call Agrif_Bc_variable(satemp,sn) 34 Agrif_UseSpecialValue = .FALSE. 35 36 rhox = Agrif_Rhox() 37 38 alpha1 = (rhox-1.)/2. 39 alpha2 = 1.-alpha1 40 41 alpha3 = (rhox-1)/(rhox+1) 42 alpha4 = 1.-alpha3 43 44 alpha6 = 2.*(rhox-1.)/(rhox+1.) 45 alpha7 = -(rhox-1)/(rhox+3) 46 alpha5 = 1. - alpha6 - alpha7 47 48 ! 49 If ((nbondi == 1).OR.(nbondi == 2)) THEN 28 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zta, zsa 29 ! 30 IF(Agrif_Root()) RETURN 31 32 Agrif_SpecialValue=0. 33 Agrif_UseSpecialValue = .TRUE. 34 zta = 0.e0 35 zsa = 0.e0 36 37 CALL Agrif_Bc_variable(zta,tn) 38 CALL Agrif_Bc_variable(zsa,sn) 39 Agrif_UseSpecialValue = .FALSE. 40 41 zrhox = Agrif_Rhox() 42 43 alpha1 = (zrhox-1.)/2. 44 alpha2 = 1.-alpha1 45 46 alpha3 = (zrhox-1)/(zrhox+1) 47 alpha4 = 1.-alpha3 48 49 alpha6 = 2.*(zrhox-1.)/(zrhox+1.) 50 alpha7 = -(zrhox-1)/(zrhox+3) 51 alpha5 = 1. - alpha6 - alpha7 52 53 IF((nbondi == 1).OR.(nbondi == 2)) THEN 54 55 ta(nlci,:,:) = alpha1 * zta(nlci,:,:) + alpha2 * zta(nlci-1,:,:) 56 sa(nlci,:,:) = alpha1 * zsa(nlci,:,:) + alpha2 * zsa(nlci-1,:,:) 57 58 DO jk=1,jpk 59 DO jj=1,jpj 60 IF (umask(nlci-2,jj,jk).EQ.0.) THEN 61 ta(nlci-1,jj,jk) = ta(nlci,jj,jk) * tmask(nlci-1,jj,jk) 62 sa(nlci-1,jj,jk) = sa(nlci,jj,jk) * tmask(nlci-1,jj,jk) 63 ELSE 64 ta(nlci-1,jj,jk)=(alpha4*ta(nlci,jj,jk)+alpha3*ta(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 65 sa(nlci-1,jj,jk)=(alpha4*sa(nlci,jj,jk)+alpha3*sa(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 66 IF (un(nlci-2,jj,jk).GT.0.) THEN 67 ta(nlci-1,jj,jk)=( alpha6*ta(nlci-2,jj,jk)+alpha5*ta(nlci,jj,jk) & 68 + alpha7*ta(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 69 sa(nlci-1,jj,jk)=( alpha6*sa(nlci-2,jj,jk)+alpha5*sa(nlci,jj,jk) & 70 + alpha7*sa(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 71 ENDIF 72 ENDIF 73 END DO 74 END DO 75 ENDIF 76 77 IF((nbondj == 1).OR.(nbondj == 2)) THEN 78 79 ta(:,nlcj,:) = alpha1 * zta(:,nlcj,:) + alpha2 * zta(:,nlcj-1,:) 80 sa(:,nlcj,:) = alpha1 * zsa(:,nlcj,:) + alpha2 * zsa(:,nlcj-1,:) 81 82 DO jk=1,jpk 83 DO ji=1,jpi 84 IF (vmask(ji,nlcj-2,jk).EQ.0.) THEN 85 ta(ji,nlcj-1,jk) = ta(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 86 sa(ji,nlcj-1,jk) = sa(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 87 ELSE 88 ta(ji,nlcj-1,jk)=(alpha4*ta(ji,nlcj,jk)+alpha3*ta(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 89 sa(ji,nlcj-1,jk)=(alpha4*sa(ji,nlcj,jk)+alpha3*sa(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 90 IF (vn(ji,nlcj-2,jk) .GT. 0.) THEN 91 ta(ji,nlcj-1,jk)=( alpha6*ta(ji,nlcj-2,jk)+alpha5*ta(ji,nlcj,jk) & 92 + alpha7*ta(ji,nlcj-3,jk) ) * tmask(ji,nlcj-1,jk) 93 sa(ji,nlcj-1,jk)=( alpha6*sa(ji,nlcj-2,jk)+alpha5*sa(ji,nlcj,jk) & 94 + alpha7*sa(ji,nlcj-3,jk))*tmask(ji,nlcj-1,jk) 95 ENDIF 96 ENDIF 97 END DO 98 END DO 99 ENDIF 100 101 IF((nbondi == -1).OR.(nbondi == 2)) THEN 102 ta(1,:,:) = alpha1 * zta(1,:,:) + alpha2 * zta(2,:,:) 103 sa(1,:,:) = alpha1 * zsa(1,:,:) + alpha2 * zsa(2,:,:) 104 DO jk=1,jpk 105 DO jj=1,jpj 106 IF (umask(2,jj,jk).EQ.0.) THEN 107 ta(2,jj,jk) = ta(1,jj,jk) * tmask(2,jj,jk) 108 sa(2,jj,jk) = sa(1,jj,jk) * tmask(2,jj,jk) 109 ELSE 110 ta(2,jj,jk)=(alpha4*ta(1,jj,jk)+alpha3*ta(3,jj,jk))*tmask(2,jj,jk) 111 sa(2,jj,jk)=(alpha4*sa(1,jj,jk)+alpha3*sa(3,jj,jk))*tmask(2,jj,jk) 112 IF (un(2,jj,jk).LT.0.) THEN 113 ta(2,jj,jk)=(alpha6*ta(3,jj,jk)+alpha5*ta(1,jj,jk)+alpha7*ta(4,jj,jk))*tmask(2,jj,jk) 114 sa(2,jj,jk)=(alpha6*sa(3,jj,jk)+alpha5*sa(1,jj,jk)+alpha7*sa(4,jj,jk))*tmask(2,jj,jk) 115 ENDIF 116 ENDIF 117 END DO 118 END DO 119 ENDIF 120 121 IF((nbondj == -1).OR.(nbondj == 2)) THEN 122 ta(:,1,:) = alpha1 * zta(:,1,:) + alpha2 * zta(:,2,:) 123 sa(:,1,:) = alpha1 * zsa(:,1,:) + alpha2 * zsa(:,2,:) 124 DO jk=1,jpk 125 DO ji=1,jpi 126 IF (vmask(ji,2,jk).EQ.0.) THEN 127 ta(ji,2,jk)=ta(ji,1,jk) * tmask(ji,2,jk) 128 sa(ji,2,jk)=sa(ji,1,jk) * tmask(ji,2,jk) 129 ELSE 130 ta(ji,2,jk)=(alpha4*ta(ji,1,jk)+alpha3*ta(ji,3,jk))*tmask(ji,2,jk) 131 sa(ji,2,jk)=(alpha4*sa(ji,1,jk)+alpha3*sa(ji,3,jk))*tmask(ji,2,jk) 132 IF (vn(ji,2,jk) .LT. 0.) THEN 133 ta(ji,2,jk)=(alpha6*ta(ji,3,jk)+alpha5*ta(ji,1,jk)+alpha7*ta(ji,4,jk))*tmask(ji,2,jk) 134 sa(ji,2,jk)=(alpha6*sa(ji,3,jk)+alpha5*sa(ji,1,jk)+alpha7*sa(ji,4,jk))*tmask(ji,2,jk) 135 ENDIF 136 ENDIF 137 END DO 138 END DO 139 ENDIF 140 141 END SUBROUTINE Agrif_tra 142 143 SUBROUTINE Agrif_dyn( kt ) 144 !!--------------------------------------------- 145 !! *** ROUTINE Agrif_DYN *** 146 !!--------------------------------------------- 147 USE phycst 148 USE in_out_manager 149 150 # include "domzgr_substitute.h90" 50 151 51 ta(nlci,:,:) = alpha1 * tatemp(nlci,:,:) + alpha2 * tatemp(nlci-1,:,:) 52 sa(nlci,:,:) = alpha1 * satemp(nlci,:,:) + alpha2 * satemp(nlci-1,:,:) 53 54 Do jk=1,jpk 55 Do jj=1,jpj 56 IF (umask(nlci-2,jj,jk).EQ.0.) THEN 57 ta(nlci-1,jj,jk) = ta(nlci,jj,jk) * tmask(nlci-1,jj,jk) 58 sa(nlci-1,jj,jk) = sa(nlci,jj,jk) * tmask(nlci-1,jj,jk) 59 ELSE 60 ta(nlci-1,jj,jk)=(alpha4*ta(nlci,jj,jk)+alpha3*ta(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 61 sa(nlci-1,jj,jk)=(alpha4*sa(nlci,jj,jk)+alpha3*sa(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 62 IF (un(nlci-2,jj,jk).GT.0.) THEN 63 ta(nlci-1,jj,jk)=(alpha6*ta(nlci-2,jj,jk)+alpha5*ta(nlci,jj,jk)+alpha7*ta(nlci-3,jj,jk))*tmask(nlci-1,jj,jk) 64 sa(nlci-1,jj,jk)=(alpha6*sa(nlci-2,jj,jk)+alpha5*sa(nlci,jj,jk)+alpha7*sa(nlci-3,jj,jk))*tmask(nlci-1,jj,jk) 65 ENDIF 66 ENDIF 67 End Do 68 enddo 69 ENDIF 70 71 If ((nbondj == 1).OR.(nbondj == 2)) THEN 72 73 ta(:,nlcj,:) = alpha1 * tatemp(:,nlcj,:) + alpha2 * tatemp(:,nlcj-1,:) 74 sa(:,nlcj,:) = alpha1 * satemp(:,nlcj,:) + alpha2 * satemp(:,nlcj-1,:) 75 76 Do jk=1,jpk 77 Do ji=1,jpi 78 IF (vmask(ji,nlcj-2,jk).EQ.0.) THEN 79 ta(ji,nlcj-1,jk) = ta(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 80 sa(ji,nlcj-1,jk) = sa(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 81 ELSE 82 ta(ji,nlcj-1,jk)=(alpha4*ta(ji,nlcj,jk)+alpha3*ta(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 83 sa(ji,nlcj-1,jk)=(alpha4*sa(ji,nlcj,jk)+alpha3*sa(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 84 IF (vn(ji,nlcj-2,jk) .GT. 0.) THEN 85 ta(ji,nlcj-1,jk)=(alpha6*ta(ji,nlcj-2,jk)+alpha5*ta(ji,nlcj,jk)+alpha7*ta(ji,nlcj-3,jk))*tmask(ji,nlcj-1,jk) 86 sa(ji,nlcj-1,jk)=(alpha6*sa(ji,nlcj-2,jk)+alpha5*sa(ji,nlcj,jk)+alpha7*sa(ji,nlcj-3,jk))*tmask(ji,nlcj-1,jk) 87 ENDIF 88 ENDIF 89 End Do 90 enddo 91 ENDIF 92 93 IF ((nbondi == -1).OR.(nbondi == 2)) THEN 94 95 ta(1,:,:) = alpha1 * tatemp(1,:,:) + alpha2 * tatemp(2,:,:) 96 sa(1,:,:) = alpha1 * satemp(1,:,:) + alpha2 * satemp(2,:,:) 97 98 Do jk=1,jpk 99 Do jj=1,jpj 100 IF (umask(2,jj,jk).EQ.0.) THEN 101 ta(2,jj,jk) = ta(1,jj,jk) * tmask(2,jj,jk) 102 sa(2,jj,jk) = sa(1,jj,jk) * tmask(2,jj,jk) 103 ELSE 104 ta(2,jj,jk)=(alpha4*ta(1,jj,jk)+alpha3*ta(3,jj,jk))*tmask(2,jj,jk) 105 sa(2,jj,jk)=(alpha4*sa(1,jj,jk)+alpha3*sa(3,jj,jk))*tmask(2,jj,jk) 106 IF (un(2,jj,jk).LT.0.) THEN 107 ta(2,jj,jk)=(alpha6*ta(3,jj,jk)+alpha5*ta(1,jj,jk)+alpha7*ta(4,jj,jk))*tmask(2,jj,jk) 108 sa(2,jj,jk)=(alpha6*sa(3,jj,jk)+alpha5*sa(1,jj,jk)+alpha7*sa(4,jj,jk))*tmask(2,jj,jk) 109 ENDIF 110 ENDIF 111 End Do 112 enddo 113 ENDIF 114 115 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 116 117 ta(:,1,:) = alpha1 * tatemp(:,1,:) + alpha2 * tatemp(:,2,:) 118 sa(:,1,:) = alpha1 * satemp(:,1,:) + alpha2 * satemp(:,2,:) 119 120 Do jk=1,jpk 121 Do ji=1,jpi 122 IF (vmask(ji,2,jk).EQ.0.) THEN 123 ta(ji,2,jk)=ta(ji,1,jk) * tmask(ji,2,jk) 124 sa(ji,2,jk)=sa(ji,1,jk) * tmask(ji,2,jk) 125 ELSE 126 ta(ji,2,jk)=(alpha4*ta(ji,1,jk)+alpha3*ta(ji,3,jk))*tmask(ji,2,jk) 127 sa(ji,2,jk)=(alpha4*sa(ji,1,jk)+alpha3*sa(ji,3,jk))*tmask(ji,2,jk) 128 IF (vn(ji,2,jk) .LT. 0.) THEN 129 ta(ji,2,jk)=(alpha6*ta(ji,3,jk)+alpha5*ta(ji,1,jk)+alpha7*ta(ji,4,jk))*tmask(ji,2,jk) 130 sa(ji,2,jk)=(alpha6*sa(ji,3,jk)+alpha5*sa(ji,1,jk)+alpha7*sa(ji,4,jk))*tmask(ji,2,jk) 131 ENDIF 132 ENDIF 133 End Do 134 enddo 135 ENDIF 136 137 Return 138 End Subroutine Agrif_tra 139 ! 140 ! 141 SUBROUTINE Agrif_dyn(kt) 142 ! 143 USE phycst 144 USE sol_oce 145 USE in_out_manager 146 147 implicit none 148 # include "domzgr_substitute.h90" 149 ! 150 REAL(wp) uatemp(jpi,jpj,jpk) , vatemp(jpi,jpj,jpk) 152 INTEGER, INTENT(in) :: kt 153 154 REAL(wp) :: timeref 155 REAL(wp) :: z2dt, znugdt 156 REAL(wp) :: zrhox, rhoy 157 REAL(wp), DIMENSION(jpi,jpj) :: zua2d, zva2d 158 REAL(wp), DIMENSION(jpi,jpj) :: spgu1,spgv1 159 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zua, zva 151 160 INTEGER :: ji,jj,jk 152 INTEGER kt153 REAL(wp) :: z2dt, znugdt154 REAL(wp), DIMENSION(jpi,jpj) :: uatemp2D, vatemp2D155 REAL(wp) :: timeref156 REAL(wp), DIMENSION(jpi,jpj) :: spgu1,spgv1157 REAL(wp) :: rhox, rhoy158 161 159 162 IF (Agrif_Root()) RETURN 160 163 161 rhox = Agrif_Rhox()164 zrhox = Agrif_Rhox() 162 165 rhoy = Agrif_Rhoy() 163 166 … … 171 174 znugdt = rnu * grav * z2dt 172 175 173 174 175 uatemp= 0.176 vatemp= 0.177 Call Agrif_Bc_variable(uatemp,un,procname=interpu)178 Call Agrif_Bc_variable(vatemp,vn,procname=interpv)179 uatemp2d = 0.180 vatemp2d = 0.181 182 183 184 Call Agrif_Bc_variable(uatemp2d,e1u,calledweight=1.,procname=interpu2d)185 Call Agrif_Bc_variable(vatemp2d,e2v,calledweight=1.,procname=interpv2d)186 187 188 189 If((nbondi == -1).OR.(nbondi == 2)) THEN190 191 DO jj=1,jpj192 laplacu(2,jj) = timeref * (uatemp2d(2,jj)/(rhoy*e2u(2,jj)))*umask(2,jj,1)193 ENDDO194 195 Dojk=1,jpkm1196 DO jj=1,jpj197 ua(1:2,jj,jk) = (uatemp(1:2,jj,jk)/(rhoy*e2u(1:2,jj)))198 #if ! defined key_zco 199 ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u(1:2,jj,jk)200 #endif 201 ENDDO202 ENDDO203 204 Dojk=1,jpkm1205 DO jj=1,jpj206 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk)207 ENDDO208 ENDDO209 210 spgu(2,:)=0.211 212 dojk=1,jpkm1213 dojj=1,jpj214 spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk)215 enddo216 enddo217 218 DO jj=1,jpj219 IF (umask(2,jj,1).NE.0.) THEN220 spgu(2,jj)=spgu(2,jj)/hu(2,jj)221 ENDIF222 enddo223 224 Dojk=1,jpkm1225 DO jj=1,jpj226 ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk))227 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk)228 ENDDO229 ENDDO230 231 spgu1(2,:)=0.232 233 dojk=1,jpkm1234 dojj=1,jpj235 spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk)236 enddo237 enddo238 239 DO jj=1,jpj240 IF (umask(2,jj,1).NE.0.) THEN241 spgu1(2,jj)=spgu1(2,jj)/hu(2,jj)242 ENDIF243 enddo244 245 DO jk=1,jpkm1246 DO jj=1,jpj247 ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk)248 ENDDO249 ENDDO250 251 Dojk=1,jpkm1252 Dojj=1,jpj253 va(2,jj,jk) = (vatemp(2,jj,jk)/(rhox*e1v(2,jj)))*vmask(2,jj,jk)254 #if ! defined key_zco 255 va(2,jj,jk) = va(2,jj,jk) / fse3v(2,jj,jk)176 Agrif_SpecialValue=0. 177 Agrif_UseSpecialValue = .TRUE. 178 zua = 0. 179 zva = 0. 180 CALL Agrif_Bc_variable(zua,un,procname=interpu) 181 CALL Agrif_Bc_variable(zva,vn,procname=interpv) 182 zua2d = 0. 183 zva2d = 0. 184 185 Agrif_SpecialValue=0. 186 Agrif_UseSpecialValue = .TRUE. 187 CALL Agrif_Bc_variable(zua2d,e1u,calledweight=1.,procname=interpu2d) 188 CALL Agrif_Bc_variable(zva2d,e2v,calledweight=1.,procname=interpv2d) 189 Agrif_UseSpecialValue = .FALSE. 190 191 192 IF((nbondi == -1).OR.(nbondi == 2)) THEN 193 194 DO jj=1,jpj 195 laplacu(2,jj) = timeref * (zua2d(2,jj)/(rhoy*e2u(2,jj)))*umask(2,jj,1) 196 END DO 197 198 DO jk=1,jpkm1 199 DO jj=1,jpj 200 ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(rhoy*e2u(1:2,jj))) 201 #if ! defined key_zco 202 ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u(1:2,jj,jk) 203 #endif 204 END DO 205 END DO 206 207 DO jk=1,jpkm1 208 DO jj=1,jpj 209 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 210 END DO 211 END DO 212 213 spgu(2,:)=0. 214 215 DO jk=1,jpkm1 216 DO jj=1,jpj 217 spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 218 END DO 219 END DO 220 221 DO jj=1,jpj 222 IF (umask(2,jj,1).NE.0.) THEN 223 spgu(2,jj)=spgu(2,jj)/hu(2,jj) 224 ENDIF 225 END DO 226 227 DO jk=1,jpkm1 228 DO jj=1,jpj 229 ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 230 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 231 END DO 232 END DO 233 234 spgu1(2,:)=0. 235 236 DO jk=1,jpkm1 237 DO jj=1,jpj 238 spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 239 END DO 240 END DO 241 242 DO jj=1,jpj 243 IF (umask(2,jj,1).NE.0.) THEN 244 spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 245 ENDIF 246 END DO 247 248 DO jk=1,jpkm1 249 DO jj=1,jpj 250 ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 251 END DO 252 END DO 253 254 DO jk=1,jpkm1 255 DO jj=1,jpj 256 va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk) 257 #if ! defined key_zco 258 va(2,jj,jk) = va(2,jj,jk) / fse3v(2,jj,jk) 256 259 #endif 257 End Do258 End Do259 260 sshn(2,:)=sshn(3,:)261 sshb(2,:)=sshb(3,:)262 263 264 265 If((nbondi == 1).OR.(nbondi == 2)) THEN266 267 DO jj=1,jpj268 laplacu(nlci-2,jj) = timeref * (uatemp2d(nlci-2,jj)/(rhoy*e2u(nlci-2,jj)))269 ENDDO270 271 Dojk=1,jpkm1272 DO jj=1,jpj273 ua(nlci-2:nlci-1,jj,jk) = (uatemp(nlci-2:nlci-1,jj,jk)/(rhoy*e2u(nlci-2:nlci-1,jj)))274 275 #if ! defined key_zco 276 ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u(nlci-2:nlci-1,jj,jk)277 #endif 278 279 ENDDO280 ENDDO281 282 Dojk=1,jpkm1283 DO jj=1,jpj284 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk)285 ENDDO286 ENDDO287 288 289 spgu(nlci-2,:)=0.290 291 do jk=1,jpkm1292 do jj=1,jpj293 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)294 enddo295 enddo296 297 DO jj=1,jpj298 IF (umask(nlci-2,jj,1).NE.0.) THEN299 spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj)300 ENDIF301 enddo302 303 Dojk=1,jpkm1304 DO jj=1,jpj305 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk))306 307 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk)308 309 ENDDO310 ENDDO311 312 spgu1(nlci-2,:)=0.313 314 dojk=1,jpkm1315 dojj=1,jpj316 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk)317 enddo318 enddo319 320 DO jj=1,jpj321 IF (umask(nlci-2,jj,1).NE.0.) THEN322 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj)323 ENDIF324 enddo325 326 DO jk=1,jpkm1327 DO jj=1,jpj328 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk)329 ENDDO330 ENDDO331 332 Dojk=1,jpkm1333 Dojj=1,jpj-1334 va(nlci-1,jj,jk) = (vatemp(nlci-1,jj,jk)/(rhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk)335 #if ! defined key_zco 336 va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v(nlci-1,jj,jk)337 #endif 338 End Do339 End Do340 341 sshn(nlci-1,:)=sshn(nlci-2,:)342 sshb(nlci-1,:)=sshb(nlci-2,:)343 344 345 If((nbondj == -1).OR.(nbondj == 2)) THEN346 347 DO ji=1,jpi348 laplacv(ji,2) = timeref * (vatemp2d(ji,2)/(rhox*e1v(ji,2)))349 ENDDO350 351 DO jk=1,jpkm1352 DO ji=1,jpi353 va(ji,1:2,jk) = (vatemp(ji,1:2,jk)/(rhox*e1v(ji,1:2)))354 #if ! defined key_zco 355 va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v(ji,1:2,jk)356 #endif 357 ENDDO358 ENDDO359 360 DO jk=1,jpkm1361 DO ji=1,jpi362 va(ji,2,jk) = (va(ji,2,jk) - z2dt * znugdt * laplacv(ji,2))*vmask(ji,2,jk)363 ENDDO364 ENDDO365 366 spgv(:,2)=0.367 368 dojk=1,jpkm1369 doji=1,jpi370 spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)371 enddo372 enddo373 374 DO ji=1,jpi375 IF (vmask(ji,2,1).NE.0.) THEN376 spgv(ji,2)=spgv(ji,2)/hv(ji,2)377 ENDIF378 enddo379 380 DO jk=1,jpkm1381 DO ji=1,jpi382 va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk))383 va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk)384 ENDDO385 ENDDO386 387 spgv1(:,2)=0.388 389 dojk=1,jpkm1390 doji=1,jpi391 spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk)392 enddo393 enddo394 395 DO ji=1,jpi396 IF (vmask(ji,2,1).NE.0.) THEN397 spgv1(ji,2)=spgv1(ji,2)/hv(ji,2)398 ENDIF399 enddo400 401 DO jk=1,jpkm1402 DO ji=1,jpi403 va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk)404 ENDDO405 ENDDO406 407 DO jk=1,jpkm1408 DO ji=1,jpi409 ua(ji,2,jk) = (uatemp(ji,2,jk)/(rhoy*e2u(ji,2)))*umask(ji,2,jk)410 #if ! defined key_zco 411 ua(ji,2,jk) = ua(ji,2,jk) / fse3u(ji,2,jk)260 END DO 261 END DO 262 263 sshn(2,:)=sshn(3,:) 264 sshb(2,:)=sshb(3,:) 265 266 ENDIF 267 268 IF((nbondi == 1).OR.(nbondi == 2)) THEN 269 270 DO jj=1,jpj 271 laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(rhoy*e2u(nlci-2,jj))) 272 END DO 273 274 DO jk=1,jpkm1 275 DO jj=1,jpj 276 ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(rhoy*e2u(nlci-2:nlci-1,jj))) 277 278 #if ! defined key_zco 279 ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u(nlci-2:nlci-1,jj,jk) 280 #endif 281 282 END DO 283 END DO 284 285 DO jk=1,jpkm1 286 DO jj=1,jpj 287 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 288 END DO 289 END DO 290 291 292 spgu(nlci-2,:)=0. 293 294 do jk=1,jpkm1 295 do jj=1,jpj 296 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 297 enddo 298 enddo 299 300 DO jj=1,jpj 301 IF (umask(nlci-2,jj,1).NE.0.) THEN 302 spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 303 ENDIF 304 END DO 305 306 DO jk=1,jpkm1 307 DO jj=1,jpj 308 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 309 310 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 311 312 END DO 313 END DO 314 315 spgu1(nlci-2,:)=0. 316 317 DO jk=1,jpkm1 318 DO jj=1,jpj 319 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 320 END DO 321 END DO 322 323 DO jj=1,jpj 324 IF (umask(nlci-2,jj,1).NE.0.) THEN 325 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 326 ENDIF 327 END DO 328 329 DO jk=1,jpkm1 330 DO jj=1,jpj 331 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 332 END DO 333 END DO 334 335 DO jk=1,jpkm1 336 DO jj=1,jpj-1 337 va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk) 338 #if ! defined key_zco 339 va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v(nlci-1,jj,jk) 340 #endif 341 END DO 342 END DO 343 344 sshn(nlci-1,:)=sshn(nlci-2,:) 345 sshb(nlci-1,:)=sshb(nlci-2,:) 346 ENDIF 347 348 IF((nbondj == -1).OR.(nbondj == 2)) THEN 349 350 DO ji=1,jpi 351 laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2))) 352 END DO 353 354 DO jk=1,jpkm1 355 DO ji=1,jpi 356 va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2))) 357 #if ! defined key_zco 358 va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v(ji,1:2,jk) 359 #endif 360 END DO 361 END DO 362 363 DO jk=1,jpkm1 364 DO ji=1,jpi 365 va(ji,2,jk) = (va(ji,2,jk) - z2dt * znugdt * laplacv(ji,2))*vmask(ji,2,jk) 366 END DO 367 END DO 368 369 spgv(:,2)=0. 370 371 DO jk=1,jpkm1 372 DO ji=1,jpi 373 spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 374 END DO 375 END DO 376 377 DO ji=1,jpi 378 IF (vmask(ji,2,1).NE.0.) THEN 379 spgv(ji,2)=spgv(ji,2)/hv(ji,2) 380 ENDIF 381 END DO 382 383 DO jk=1,jpkm1 384 DO ji=1,jpi 385 va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 386 va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 387 END DO 388 END DO 389 390 spgv1(:,2)=0. 391 392 DO jk=1,jpkm1 393 DO ji=1,jpi 394 spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 395 END DO 396 END DO 397 398 DO ji=1,jpi 399 IF (vmask(ji,2,1).NE.0.) THEN 400 spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 401 ENDIF 402 END DO 403 404 DO jk=1,jpkm1 405 DO ji=1,jpi 406 va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 407 END DO 408 END DO 409 410 DO jk=1,jpkm1 411 DO ji=1,jpi 412 ua(ji,2,jk) = (zua(ji,2,jk)/(rhoy*e2u(ji,2)))*umask(ji,2,jk) 413 #if ! defined key_zco 414 ua(ji,2,jk) = ua(ji,2,jk) / fse3u(ji,2,jk) 412 415 #endif 413 ENDDO414 ENDDO415 416 sshn(:,2)=sshn(:,3)417 sshb(:,2)=sshb(:,3)418 419 420 If((nbondj == 1).OR.(nbondj == 2)) THEN421 422 DO ji=1,jpi423 laplacv(ji,nlcj-2) = timeref * (vatemp2d(ji,nlcj-2)/(rhox*e1v(ji,nlcj-2)))424 ENDDO425 426 DO jk=1,jpkm1427 DO ji=1,jpi428 va(ji,nlcj-2:nlcj-1,jk) = (vatemp(ji,nlcj-2:nlcj-1,jk)/(rhox*e1v(ji,nlcj-2:nlcj-1)))429 #if ! defined key_zco 430 va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v(ji,nlcj-2:nlcj-1,jk)431 #endif 432 ENDDO433 ENDDO434 435 DO jk=1,jpkm1436 DO ji=1,jpi437 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)-z2dt * znugdt * laplacv(ji,nlcj-2))*vmask(ji,nlcj-2,jk)438 ENDDO439 ENDDO440 441 442 spgv(:,nlcj-2)=0.443 444 dojk=1,jpkm1445 doji=1,jpi446 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)447 enddo448 enddo449 450 DO ji=1,jpi451 IF (vmask(ji,nlcj-2,1).NE.0.) THEN452 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2)453 ENDIF454 enddo455 456 DO jk=1,jpkm1457 DO ji=1,jpi458 va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk))459 va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk)460 ENDDO461 ENDDO462 463 spgv1(:,nlcj-2)=0.464 465 dojk=1,jpkm1466 doji=1,jpi467 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)468 enddo469 enddo470 471 DO ji=1,jpi472 IF (vmask(ji,nlcj-2,1).NE.0.) THEN473 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2)474 ENDIF475 enddo476 477 DO jk=1,jpkm1478 DO ji=1,jpi479 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk)480 ENDDO481 ENDDO482 483 DO jk=1,jpkm1484 DO ji=1,jpi485 ua(ji,nlcj-1,jk) = (uatemp(ji,nlcj-1,jk)/(rhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk)486 #if ! defined key_zco 487 ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u(ji,nlcj-1,jk)416 END DO 417 END DO 418 419 sshn(:,2)=sshn(:,3) 420 sshb(:,2)=sshb(:,3) 421 ENDIF 422 423 IF((nbondj == 1).OR.(nbondj == 2)) THEN 424 425 DO ji=1,jpi 426 laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2))) 427 END DO 428 429 DO jk=1,jpkm1 430 DO ji=1,jpi 431 va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1))) 432 #if ! defined key_zco 433 va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v(ji,nlcj-2:nlcj-1,jk) 434 #endif 435 END DO 436 END DO 437 438 DO jk=1,jpkm1 439 DO ji=1,jpi 440 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)-z2dt * znugdt * laplacv(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 441 END DO 442 END DO 443 444 445 spgv(:,nlcj-2)=0. 446 447 DO jk=1,jpkm1 448 DO ji=1,jpi 449 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 450 END DO 451 END DO 452 453 DO ji=1,jpi 454 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 455 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 456 ENDIF 457 END DO 458 459 DO jk=1,jpkm1 460 DO ji=1,jpi 461 va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 462 va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 463 END DO 464 END DO 465 466 spgv1(:,nlcj-2)=0. 467 468 DO jk=1,jpkm1 469 DO ji=1,jpi 470 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 471 END DO 472 END DO 473 474 DO ji=1,jpi 475 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 476 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 477 ENDIF 478 END DO 479 480 DO jk=1,jpkm1 481 DO ji=1,jpi 482 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 483 END DO 484 END DO 485 486 DO jk=1,jpkm1 487 DO ji=1,jpi 488 ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(rhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk) 489 #if ! defined key_zco 490 ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u(ji,nlcj-1,jk) 488 491 #endif 489 ENDDO 490 ENDDO 491 492 sshn(:,nlcj-1)=sshn(:,nlcj-2) 493 sshb(:,nlcj-1)=sshb(:,nlcj-2) 494 ENDIF 495 496 ! 497 Return 498 End Subroutine Agrif_dyn 499 500 501 subroutine interpu(tabres,i1,i2,j1,j2,k1,k2) 502 Implicit none 503 # include "domzgr_substitute.h90" 504 integer i1,i2,j1,j2,k1,k2 505 integer ji,jj,jk 506 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 507 508 do jk=k1,k2 509 DO jj=j1,j2 510 DO ji=i1,i2 511 tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 512 #if ! defined key_zco 513 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk) 514 #endif 515 ENDDO 516 ENDDO 517 ENDDO 518 end subroutine interpu 519 520 subroutine interpu2d(tabres,i1,i2,j1,j2) 521 Implicit none 522 integer i1,i2,j1,j2 523 integer ji,jj 524 real,dimension(i1:i2,j1:j2) :: tabres 525 526 DO jj=j1,j2 527 DO ji=i1,i2 528 tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) & 529 *umask(ji,jj,1) 530 ENDDO 531 ENDDO 532 end subroutine interpu2d 533 534 subroutine interpv(tabres,i1,i2,j1,j2,k1,k2) 535 Implicit none 536 # include "domzgr_substitute.h90" 537 integer i1,i2,j1,j2,k1,k2 538 integer ji,jj,jk 539 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 540 541 do jk=k1,k2 542 DO jj=j1,j2 543 DO ji=i1,i2 544 tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 545 #if ! defined key_zco 546 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk) 492 END DO 493 END DO 494 495 sshn(:,nlcj-1)=sshn(:,nlcj-2) 496 sshb(:,nlcj-1)=sshb(:,nlcj-2) 497 ENDIF 498 499 END SUBROUTINE Agrif_dyn 500 501 SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 502 !!--------------------------------------------- 503 !! *** ROUTINE interpu *** 504 !!--------------------------------------------- 505 # include "domzgr_substitute.h90" 506 507 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 508 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 509 510 INTEGER :: ji,jj,jk 511 512 DO jk=k1,k2 513 DO jj=j1,j2 514 DO ji=i1,i2 515 tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 516 #if ! defined key_zco 517 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk) 518 #endif 519 END DO 520 END DO 521 END DO 522 END SUBROUTINE interpu 523 524 SUBROUTINE interpu2d(tabres,i1,i2,j1,j2) 525 !!--------------------------------------------- 526 !! *** ROUTINE interpu2d *** 527 !!--------------------------------------------- 528 529 INTEGER, INTENT(in) :: i1,i2,j1,j2 530 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 531 532 INTEGER :: ji,jj 533 534 DO jj=j1,j2 535 DO ji=i1,i2 536 tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) & 537 * umask(ji,jj,1) 538 END DO 539 END DO 540 541 END SUBROUTINE interpu2d 542 543 SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2) 544 !!--------------------------------------------- 545 !! *** ROUTINE interpv *** 546 !!--------------------------------------------- 547 # include "domzgr_substitute.h90" 548 549 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 550 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 551 552 INTEGER :: ji, jj, jk 553 554 DO jk=k1,k2 555 DO jj=j1,j2 556 DO ji=i1,i2 557 tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 558 #if ! defined key_zco 559 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk) 547 560 #endif 548 ENDDO 549 ENDDO 550 ENDDO 551 end subroutine interpv 552 553 subroutine interpv2d(tabres,i1,i2,j1,j2) 554 Implicit none 555 integer i1,i2,j1,j2 556 integer ji,jj 557 real,dimension(i1:i2,j1:j2) :: tabres 558 559 DO jj=j1,j2 560 DO ji=i1,i2 561 tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) & 562 * vmask(ji,jj,1) 563 ENDDO 564 ENDDO 565 end subroutine interpv2d 561 END DO 562 END DO 563 END DO 564 565 END SUBROUTINE interpv 566 567 SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 568 !!--------------------------------------------- 569 !! *** ROUTINE interpv2d *** 570 !!--------------------------------------------- 571 572 INTEGER, INTENT(in) :: i1,i2,j1,j2 573 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 574 575 INTEGER :: ji,jj 576 577 DO jj=j1,j2 578 DO ji=i1,i2 579 tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) & 580 * vmask(ji,jj,1) 581 END DO 582 END DO 583 584 END SUBROUTINE interpv2d 566 585 567 586 #else 568 CONTAINS 569 subroutine Agrif_OPA_Interp_empty 570 571 end subroutine Agrif_OPA_Interp_empty 572 #endif 573 End Module agrif_opa_interp 574 587 CONTAINS 588 589 SUBROUTINE Agrif_OPA_Interp_empty 590 !!--------------------------------------------- 591 !! *** ROUTINE agrif_OPA_Interp_empty *** 592 !!--------------------------------------------- 593 WRITE(*,*) 'agrif_opa_interp : You should not have seen this print! error?' 594 END SUBROUTINE Agrif_OPA_Interp_empty 595 #endif 596 END MODULE agrif_opa_interp 597 -
trunk/NEMO/NST_SRC/agrif_opa_sponge.F90
r469 r636 1 1 #define SPONGE 2 2 3 3 Module agrif_opa_sponge 4 4 #if defined key_agrif 5 USE par_oce 6 USE oce 7 USE dom_oce 8 9 Contains 10 11 12 Subroutine Agrif_Sponge_Tra( kt ) 13 14 implicit none 15 16 INTEGER :: kt 17 REAL(wp), DIMENSION(jpi,jpj,jpk) :: tabtemp, tbdiff, sbdiff 5 USE par_oce 6 USE oce 7 USE dom_oce 8 USE in_out_manager 9 10 IMPLICIT NONE 11 PRIVATE 12 13 PUBLIC Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptn, interpsn, interpun, interpvn 14 15 !! * Namelist (namagrif) 16 REAL(wp) :: visc_tra = rdt 17 REAL(wp) :: visc_dyn = rdt 18 19 CONTAINS 20 21 SUBROUTINE Agrif_Sponge_Tra( kt ) 22 !!--------------------------------------------- 23 !! *** ROUTINE Agrif_Sponge_Tra *** 24 !!--------------------------------------------- 25 #include "domzgr_substitute.h90" 26 27 INTEGER, INTENT(in) :: kt 28 18 29 INTEGER :: ji,jj,jk 19 REAL(wp) :: viscsponge20 30 REAL(wp), DIMENSION(jpi,jpj,jpk) :: umasktemp,vmasktemp 21 31 INTEGER :: spongearea 22 integer ipt,jpt23 real,dimension(:,:),pointer :: e1tparent,e2tparent32 REAL(wp) :: timecoeff 33 REAL(wp) :: zta, zsa, zabe1, zabe2, zbtr 24 34 REAL(wp), DIMENSION(jpi,jpj) :: localviscsponge 25 real(wp) :: timecoeff35 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztab, tbdiff, sbdiff 26 36 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu ,ztv, zsu ,zsv 27 REAL(wp) :: zta, zsa, zabe1, zabe2, zbtr 28 29 #include "domzgr_substitute.h90" 30 31 37 32 38 #if defined SPONGE 33 39 34 timecoeff = real(Agrif_NbStepint())/Agrif_rhot() 40 IF( kt == nit000 ) CALL agrif_sponge_init 41 42 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 35 43 36 44 Agrif_SpecialValue=0. 37 45 Agrif_UseSpecialValue = .TRUE. 38 tabtemp = 0.39 C all Agrif_Bc_Variable(tabtemp, ta,calledweight=timecoeff,procname=interptn)46 ztab = 0.e0 47 CALL Agrif_Bc_Variable(ztab, ta,calledweight=timecoeff,procname=interptn) 40 48 Agrif_UseSpecialValue = .FALSE. 41 49 42 tbdiff(:,:,:) = tb(:,:,:) - tabtemp(:,:,:)43 44 tabtemp = 0.50 tbdiff(:,:,:) = tb(:,:,:) - ztab(:,:,:) 51 52 ztab = 0.e0 45 53 Agrif_SpecialValue=0. 46 54 Agrif_UseSpecialValue = .TRUE. 47 C all Agrif_Bc_Variable(tabtemp, sa,calledweight=timecoeff,procname=interpsn)55 CALL Agrif_Bc_Variable(ztab, sa,calledweight=timecoeff,procname=interpsn) 48 56 Agrif_UseSpecialValue = .FALSE. 49 57 50 sbdiff(:,:,:) = sb(:,:,:) - tabtemp(:,:,:) 51 52 viscsponge = rdt 58 sbdiff(:,:,:) = sb(:,:,:) - ztab(:,:,:) 53 59 54 60 spongearea = 2 + 2 * Agrif_irhox() … … 59 65 60 66 IF ((nbondi == -1).OR.(nbondi == 2)) THEN 61 62 DO ji = 2, spongearea 63 localviscsponge(ji,:) = viscsponge * (spongearea-ji)/real(spongearea-2) 64 ENDDO 65 66 DO jk = 1, jpkm1 67 umasktemp(2:spongearea-1,:,jk) = umask(2:spongearea-1,:,jk) & 68 * 0.5 * (localviscsponge(2:spongearea-1,:) + localviscsponge(3:spongearea,:)) 69 ENDDO 70 71 DO jk = 1, jpkm1 72 vmasktemp(2:spongearea,1:jpjm1,jk) = vmask(2:spongearea,1:jpjm1,jk) & 73 * 0.5 * (localviscsponge(2:spongearea,1:jpjm1) + localviscsponge(2:spongearea,2:jpj)) 74 ENDDO 75 67 DO ji = 2, spongearea 68 localviscsponge(ji,:) = visc_tra * (spongearea-ji)/real(spongearea-2) 69 ENDDO 70 DO jk = 1, jpkm1 71 umasktemp(2:spongearea-1,:,jk) = umask(2:spongearea-1,:,jk) & 72 * 0.5 * (localviscsponge(2:spongearea-1,:) + localviscsponge(3:spongearea,:)) 73 ENDDO 74 DO jk = 1, jpkm1 75 vmasktemp(2:spongearea,1:jpjm1,jk) = vmask(2:spongearea,1:jpjm1,jk) & 76 * 0.5 * (localviscsponge(2:spongearea,1:jpjm1) + localviscsponge(2:spongearea,2:jpj)) 77 ENDDO 76 78 ENDIF 77 79 78 80 IF ((nbondi == 1).OR.(nbondi == 2)) THEN 79 80 DO ji = nlci-spongearea + 1,nlci-1 81 localviscsponge(ji,:) = viscsponge * (ji - (nlci-spongearea+1))/real(spongearea-2) 82 ENDDO 83 84 DO jk = 1, jpkm1 85 umasktemp(nlci-spongearea + 1:nlci-2,:,jk) = umask(nlci-spongearea + 1:nlci-2,:,jk) & 86 * 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-2,:) + localviscsponge(nlci-spongearea + 2:nlci-1,:)) 87 ENDDO 88 89 DO jk = 1, jpkm1 90 vmasktemp(nlci-spongearea + 1:nlci-1,1:jpjm1,jk) = vmask(nlci-spongearea + 1:nlci-1,1:jpjm1,jk) & 91 * 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-1,1:jpjm1) + localviscsponge(nlci-spongearea + 1:nlci-1,2:jpj)) 92 ENDDO 93 94 ENDIF 95 81 DO ji = nlci-spongearea + 1,nlci-1 82 localviscsponge(ji,:) = visc_tra * (ji - (nlci-spongearea+1))/real(spongearea-2) 83 ENDDO 84 DO jk = 1, jpkm1 85 umasktemp(nlci-spongearea + 1:nlci-2,:,jk) = umask(nlci-spongearea + 1:nlci-2,:,jk) & 86 * 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-2,:) + localviscsponge(nlci-spongearea + 2:nlci-1,:)) 87 ENDDO 88 DO jk = 1, jpkm1 89 vmasktemp(nlci-spongearea + 1:nlci-1,1:jpjm1,jk) = vmask(nlci-spongearea + 1:nlci-1,1:jpjm1,jk) & 90 * 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-1,1:jpjm1) + localviscsponge(nlci-spongearea + 1:nlci-1,2:jpj)) 91 ENDDO 92 ENDIF 96 93 97 94 98 95 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 99 100 DO jj = 2, spongearea 101 localviscsponge(:,jj) = viscsponge * (spongearea-jj)/real(spongearea-2) 102 ENDDO 103 104 DO jk = 1, jpkm1 105 vmasktemp(:,2:spongearea-1,jk) = vmask(:,2:spongearea-1,jk) & 106 * 0.5 * (localviscsponge(:,2:spongearea-1) + localviscsponge(:,3:spongearea)) 107 ENDDO 108 109 DO jk = 1, jpkm1 110 umasktemp(1:jpim1,2:spongearea,jk) = umask(1:jpim1,2:spongearea,jk) & 111 * 0.5 * (localviscsponge(1:jpim1,2:spongearea) + localviscsponge(2:jpi,2:spongearea)) 112 ENDDO 113 96 DO jj = 2, spongearea 97 localviscsponge(:,jj) = visc_tra * (spongearea-jj)/real(spongearea-2) 98 ENDDO 99 DO jk = 1, jpkm1 100 vmasktemp(:,2:spongearea-1,jk) = vmask(:,2:spongearea-1,jk) & 101 * 0.5 * (localviscsponge(:,2:spongearea-1) + localviscsponge(:,3:spongearea)) 102 ENDDO 103 DO jk = 1, jpkm1 104 umasktemp(1:jpim1,2:spongearea,jk) = umask(1:jpim1,2:spongearea,jk) & 105 * 0.5 * (localviscsponge(1:jpim1,2:spongearea) + localviscsponge(2:jpi,2:spongearea)) 106 ENDDO 114 107 ENDIF 115 108 116 109 IF ((nbondj == 1).OR.(nbondj == 2)) THEN 117 118 DO jj = nlcj-spongearea + 1,nlcj-1 119 localviscsponge(:,jj) = viscsponge * (jj - (nlcj-spongearea+1))/real(spongearea-2) 120 ENDDO 121 122 DO jk = 1, jpkm1 123 vmasktemp(:,nlcj-spongearea + 1:nlcj-2,jk) = vmask(:,nlcj-spongearea + 1:nlcj-2,jk) & 124 * 0.5 * (localviscsponge(:,nlcj-spongearea + 1:nlcj-2) + localviscsponge(:,nlcj-spongearea + 2:nlcj-1)) 125 ENDDO 126 127 DO jk = 1, jpkm1 128 umasktemp(1:jpim1,nlcj-spongearea + 1:nlcj-1,jk) = umask(1:jpim1,nlcj-spongearea + 1:nlcj-1,jk) & 129 * 0.5 * (localviscsponge(1:jpim1,nlcj-spongearea + 1:nlcj-1) + localviscsponge(2:jpi,nlcj-spongearea + 1:nlcj-1)) 130 ENDDO 131 132 ENDIF 133 134 IF (.Not. spongedoneT) THEN 110 DO jj = nlcj-spongearea + 1,nlcj-1 111 localviscsponge(:,jj) = visc_tra * (jj - (nlcj-spongearea+1))/real(spongearea-2) 112 ENDDO 113 DO jk = 1, jpkm1 114 vmasktemp(:,nlcj-spongearea + 1:nlcj-2,jk) = vmask(:,nlcj-spongearea + 1:nlcj-2,jk) & 115 * 0.5 * (localviscsponge(:,nlcj-spongearea + 1:nlcj-2) + localviscsponge(:,nlcj-spongearea + 2:nlcj-1)) 116 ENDDO 117 DO jk = 1, jpkm1 118 umasktemp(1:jpim1,nlcj-spongearea + 1:nlcj-1,jk) = umask(1:jpim1,nlcj-spongearea + 1:nlcj-1,jk) & 119 * 0.5 * (localviscsponge(1:jpim1,nlcj-spongearea + 1:nlcj-1) + localviscsponge(2:jpi,nlcj-spongearea + 1:nlcj-1)) 120 ENDDO 121 ENDIF 122 123 IF (.NOT. spongedoneT) THEN 135 124 zspe1ur(:,:) = e2u(:,:) / e1u(:,:) 136 125 zspe2vr(:,:) = e1v(:,:) / e2v(:,:) 137 126 zspbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:)) 138 127 139 128 spongedoneT = .TRUE. 140 129 ENDIF 141 130 142 143 131 DO jk = 1, jpkm1 132 DO jj = 1, jpjm1 144 133 DO ji = 1, jpim1 145 134 #if defined key_zco … … 155 144 zsv(ji,jj,jk) = zabe2 * ( sbdiff(ji ,jj+1,jk) - sbdiff(ji,jj,jk) ) 156 145 ENDDO 157 146 ENDDO 158 147 159 148 DO jj = 2,jpjm1 … … 175 164 END DO 176 165 177 ENDDO 178 179 #endif 180 181 Return 182 End Subroutine Agrif_Sponge_Tra 183 184 Subroutine Agrif_Sponge_dyn( kt ) 185 186 implicit none 187 188 INTEGER :: kt 189 REAL(wp), DIMENSION(jpi,jpj,jpk) :: tabtemp, ubdiff, vbdiff,rotdiff,hdivdiff 166 ENDDO 167 168 #endif 169 170 END SUBROUTINE Agrif_Sponge_Tra 171 172 SUBROUTINE Agrif_Sponge_dyn( kt ) 173 !!--------------------------------------------- 174 !! *** ROUTINE Agrif_Sponge_dyn *** 175 !!--------------------------------------------- 176 #include "domzgr_substitute.h90" 177 178 INTEGER,INTENT(in) :: kt 179 190 180 INTEGER :: ji,jj,jk 191 REAL(wp) :: viscsponge 181 INTEGER :: spongearea 182 REAL(wp) :: timecoeff 183 REAL(wp) :: ze2u, ze1v, zua, zva 184 REAL(wp), DIMENSION(jpi,jpj) :: localviscsponge 185 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztab, ubdiff, vbdiff,rotdiff,hdivdiff 192 186 REAL(wp), DIMENSION(jpi,jpj,jpk) :: umasktemp,vmasktemp 193 INTEGER :: spongearea194 integer ipt,jpt195 real,dimension(:,:),pointer :: e1tparent,e2tparent196 REAL(wp), DIMENSION(jpi,jpj) :: localviscsponge197 real(wp) :: timecoeff198 REAL(wp):: ze2u, ze1v, zua, zva199 200 #include "domzgr_substitute.h90"201 187 202 188 #if defined SPONGE 203 189 204 timecoeff = real(Agrif_NbStepint())/Agrif_rhot()190 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 205 191 206 192 Agrif_SpecialValue=0. 207 193 Agrif_UseSpecialValue = .TRUE. 208 tabtemp = 0.209 C all Agrif_Bc_Variable(tabtemp, ua,calledweight=timecoeff,procname=interpun)194 ztab = 0.e0 195 CALL Agrif_Bc_Variable(ztab, ua,calledweight=timecoeff,procname=interpun) 210 196 Agrif_UseSpecialValue = .FALSE. 211 197 212 ubdiff(:,:,:) = ub(:,:,:) - tabtemp(:,:,:)213 214 tabtemp = 0.198 ubdiff(:,:,:) = ub(:,:,:) - ztab(:,:,:) 199 200 ztab = 0.e0 215 201 Agrif_SpecialValue=0. 216 202 Agrif_UseSpecialValue = .TRUE. 217 C all Agrif_Bc_Variable(tabtemp, va,calledweight=timecoeff,procname=interpvn)203 CALL Agrif_Bc_Variable(ztab, va,calledweight=timecoeff,procname=interpvn) 218 204 Agrif_UseSpecialValue = .FALSE. 219 205 220 vbdiff(:,:,:) = vb(:,:,:) - tabtemp(:,:,:) 221 222 viscsponge = rdt 206 vbdiff(:,:,:) = vb(:,:,:) - ztab(:,:,:) 223 207 224 208 spongearea = 2 + 2 * Agrif_irhox() … … 229 213 230 214 IF ((nbondi == -1).OR.(nbondi == 2)) THEN 231 232 DO ji = 2, spongearea 233 localviscsponge(ji,:) = viscsponge * (spongearea-ji)/real(spongearea-2) 234 ENDDO 235 236 DO jk = 1, jpkm1 237 umasktemp(2:spongearea-1,:,jk) = umask(2:spongearea-1,:,jk) & 238 * 0.5 * (localviscsponge(2:spongearea-1,:) + localviscsponge(3:spongearea,:)) 239 ENDDO 240 241 DO jk = 1, jpkm1 242 vmasktemp(2:spongearea,1:jpjm1,jk) = vmask(2:spongearea,1:jpjm1,jk) & 243 * 0.5 * (localviscsponge(2:spongearea,1:jpjm1) + localviscsponge(2:spongearea,2:jpj)) 244 ENDDO 245 215 DO ji = 2, spongearea 216 localviscsponge(ji,:) = visc_dyn * (spongearea-ji)/real(spongearea-2) 217 ENDDO 218 DO jk = 1, jpkm1 219 umasktemp(2:spongearea-1,:,jk) = umask(2:spongearea-1,:,jk) & 220 * 0.5 * (localviscsponge(2:spongearea-1,:) + localviscsponge(3:spongearea,:)) 221 ENDDO 222 DO jk = 1, jpkm1 223 vmasktemp(2:spongearea,1:jpjm1,jk) = vmask(2:spongearea,1:jpjm1,jk) & 224 * 0.5 * (localviscsponge(2:spongearea,1:jpjm1) + localviscsponge(2:spongearea,2:jpj)) 225 ENDDO 246 226 ENDIF 247 227 248 228 IF ((nbondi == 1).OR.(nbondi == 2)) THEN 249 250 DO ji = nlci-spongearea + 1,nlci-1 251 localviscsponge(ji,:) = viscsponge * (ji - (nlci-spongearea+1))/real(spongearea-2) 252 ENDDO 253 254 DO jk = 1, jpkm1 255 umasktemp(nlci-spongearea + 1:nlci-2,:,jk) = umask(nlci-spongearea + 1:nlci-2,:,jk) & 256 * 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-2,:) + localviscsponge(nlci-spongearea + 2:nlci-1,:)) 257 ENDDO 258 259 DO jk = 1, jpkm1 260 vmasktemp(nlci-spongearea + 1:nlci-1,1:jpjm1,jk) = vmask(nlci-spongearea + 1:nlci-1,1:jpjm1,jk) & 261 * 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-1,1:jpjm1) + localviscsponge(nlci-spongearea + 1:nlci-1,2:jpj)) 262 ENDDO 263 264 ENDIF 265 266 229 DO ji = nlci-spongearea + 1,nlci-1 230 localviscsponge(ji,:) = visc_dyn * (ji - (nlci-spongearea+1))/real(spongearea-2) 231 ENDDO 232 DO jk = 1, jpkm1 233 umasktemp(nlci-spongearea + 1:nlci-2,:,jk) = umask(nlci-spongearea + 1:nlci-2,:,jk) & 234 * 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-2,:) + localviscsponge(nlci-spongearea + 2:nlci-1,:)) 235 ENDDO 236 DO jk = 1, jpkm1 237 vmasktemp(nlci-spongearea + 1:nlci-1,1:jpjm1,jk) = vmask(nlci-spongearea + 1:nlci-1,1:jpjm1,jk) & 238 * 0.5 * (localviscsponge(nlci-spongearea + 1:nlci-1,1:jpjm1) + localviscsponge(nlci-spongearea + 1:nlci-1,2:jpj)) 239 ENDDO 240 ENDIF 267 241 268 242 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 269 270 DO jj = 2, spongearea 271 localviscsponge(:,jj) = viscsponge * (spongearea-jj)/real(spongearea-2) 272 ENDDO 273 274 DO jk = 1, jpkm1 275 vmasktemp(:,2:spongearea-1,jk) = vmask(:,2:spongearea-1,jk) & 276 * 0.5 * (localviscsponge(:,2:spongearea-1) + localviscsponge(:,3:spongearea)) 277 ENDDO 278 279 DO jk = 1, jpkm1 280 umasktemp(1:jpim1,2:spongearea,jk) = umask(1:jpim1,2:spongearea,jk) & 281 * 0.5 * (localviscsponge(1:jpim1,2:spongearea) + localviscsponge(2:jpi,2:spongearea)) 282 ENDDO 283 243 DO jj = 2, spongearea 244 localviscsponge(:,jj) = visc_dyn * (spongearea-jj)/real(spongearea-2) 245 ENDDO 246 DO jk = 1, jpkm1 247 vmasktemp(:,2:spongearea-1,jk) = vmask(:,2:spongearea-1,jk) & 248 * 0.5 * (localviscsponge(:,2:spongearea-1) + localviscsponge(:,3:spongearea)) 249 ENDDO 250 DO jk = 1, jpkm1 251 umasktemp(1:jpim1,2:spongearea,jk) = umask(1:jpim1,2:spongearea,jk) & 252 * 0.5 * (localviscsponge(1:jpim1,2:spongearea) + localviscsponge(2:jpi,2:spongearea)) 253 ENDDO 284 254 ENDIF 285 255 286 256 IF ((nbondj == 1).OR.(nbondj == 2)) THEN 287 288 DO jj = nlcj-spongearea + 1,nlcj-1 289 localviscsponge(:,jj) = viscsponge * (jj - (nlcj-spongearea+1))/real(spongearea-2) 290 ENDDO 291 292 DO jk = 1, jpkm1 293 vmasktemp(:,nlcj-spongearea + 1:nlcj-2,jk) = vmask(:,nlcj-spongearea + 1:nlcj-2,jk) & 294 * 0.5 * (localviscsponge(:,nlcj-spongearea + 1:nlcj-2) + localviscsponge(:,nlcj-spongearea + 2:nlcj-1)) 295 ENDDO 296 297 DO jk = 1, jpkm1 298 umasktemp(1:jpim1,nlcj-spongearea + 1:nlcj-1,jk) = umask(1:jpim1,nlcj-spongearea + 1:nlcj-1,jk) & 299 * 0.5 * (localviscsponge(1:jpim1,nlcj-spongearea + 1:nlcj-1) + localviscsponge(2:jpi,nlcj-spongearea + 1:nlcj-1)) 300 ENDDO 301 302 ENDIF 303 257 DO jj = nlcj-spongearea + 1,nlcj-1 258 localviscsponge(:,jj) = visc_dyn * (jj - (nlcj-spongearea+1))/real(spongearea-2) 259 ENDDO 260 DO jk = 1, jpkm1 261 vmasktemp(:,nlcj-spongearea + 1:nlcj-2,jk) = vmask(:,nlcj-spongearea + 1:nlcj-2,jk) & 262 * 0.5 * (localviscsponge(:,nlcj-spongearea + 1:nlcj-2) + localviscsponge(:,nlcj-spongearea + 2:nlcj-1)) 263 ENDDO 264 DO jk = 1, jpkm1 265 umasktemp(1:jpim1,nlcj-spongearea + 1:nlcj-1,jk) = umask(1:jpim1,nlcj-spongearea + 1:nlcj-1,jk) & 266 * 0.5 * (localviscsponge(1:jpim1,nlcj-spongearea + 1:nlcj-1) + localviscsponge(2:jpi,nlcj-spongearea + 1:nlcj-1)) 267 ENDDO 268 ENDIF 269 304 270 ubdiff = ubdiff * umasktemp 305 271 vbdiff = vbdiff * vmasktemp 306 272 307 273 hdivdiff = 0. 308 274 rotdiff = 0. … … 318 284 #if defined key_zco 319 285 hdivdiff(ji,jj,jk) = ( e2u(ji,jj) * ubdiff(ji,jj,jk) & 320 - e2u(ji-1,jj ) * ubdiff(ji-1,jj ,jk) &321 & + e1v(ji,jj) * vbdiff(ji,jj,jk) - &322 & e1v(ji ,jj-1) * vbdiff(ji ,jj-1,jk) ) &323 & / ( e1t(ji,jj) * e2t(ji,jj) )286 - e2u(ji-1,jj ) * ubdiff(ji-1,jj ,jk) & 287 & + e1v(ji,jj) * vbdiff(ji,jj,jk) - & 288 & e1v(ji ,jj-1) * vbdiff(ji ,jj-1,jk) ) & 289 & / ( e1t(ji,jj) * e2t(ji,jj) ) 324 290 #else 325 291 hdivdiff(ji,jj,jk) = & … … 327 293 ubdiff(ji,jj,jk) - e2u(ji-1,jj )* & 328 294 fse3u(ji-1,jj ,jk) * ubdiff(ji-1,jj ,jk) & 329 295 + e1v(ji,jj)*fse3v(ji,jj,jk) * & 330 296 vbdiff(ji,jj,jk) - e1v(ji ,jj-1)* & 331 297 fse3v(ji ,jj-1,jk) * vbdiff(ji ,jj-1,jk) ) & … … 334 300 END DO 335 301 END DO 336 302 337 303 DO jj = 1, jpjm1 338 304 DO ji = 1, jpim1 ! vector opt. … … 342 308 END DO 343 309 END DO 344 345 346 310 311 ENDDO 312 347 313 ! ! =============== 348 314 DO jk = 1, jpkm1 ! Horizontal slab … … 355 321 ze1v = hdivdiff(ji,jj,jk) 356 322 zua = - ( ze2u - & 357 rotdiff (ji,jj-1,jk) ) / e2u(ji,jj) &358 359 ze1v ) / e1u(ji,jj)323 rotdiff (ji,jj-1,jk) ) / e2u(ji,jj) & 324 + ( hdivdiff(ji+1,jj,jk) - & 325 ze1v ) / e1u(ji,jj) 360 326 361 327 zva = + ( ze2u - & 362 rotdiff (ji-1,jj,jk) ) / e1v(ji,jj) &363 364 ze1v ) / e2v(ji,jj)328 rotdiff (ji-1,jj,jk) ) / e1v(ji,jj) & 329 + ( hdivdiff(ji,jj+1,jk) - & 330 ze1v ) / e2v(ji,jj) 365 331 #else 366 332 ze2u = rotdiff (ji,jj,jk)*fse3f(ji,jj,jk) … … 368 334 ! horizontal diffusive trends 369 335 zua = - ( ze2u - rotdiff (ji,jj-1,jk)* & 370 fse3f(ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) &371 372 ) / e1u(ji,jj)336 fse3f(ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) & 337 + ( hdivdiff(ji+1,jj,jk) - ze1v & 338 ) / e1u(ji,jj) 373 339 374 340 zva = + ( ze2u - rotdiff (ji-1,jj,jk)* & 375 fse3f(ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) &376 377 341 fse3f(ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) & 342 + ( hdivdiff(ji,jj+1,jk) - ze1v & 343 ) / e2v(ji,jj) 378 344 #endif 379 345 380 346 ! add it to the general momentum trends 381 382 347 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 383 348 va(ji,jj,jk) = va(ji,jj,jk) + zva … … 390 355 #endif 391 356 392 Return 393 End Subroutine Agrif_Sponge_dyn 394 395 subroutine interptn(tabres,i1,i2,j1,j2,k1,k2) 396 Implicit none 357 END SUBROUTINE Agrif_Sponge_dyn 358 359 SUBROUTINE agrif_sponge_init 360 !!--------------------------------------------- 361 !! *** ROUTINE agrif_sponge_init *** 362 !!--------------------------------------------- 363 NAMELIST/namagrif/ visc_tra, visc_dyn 364 REWIND ( numnam ) 365 READ ( numnam, namagrif ) 366 367 IF(lwp) THEN 368 WRITE(numout,*) 369 WRITE(numout,*) 'agrif_sponge_init : agrif sponge parameters' 370 WRITE(numout,*) '~~~~~~~~~~~~' 371 WRITE(numout,*) ' Namelist namagrif : set sponge parameters' 372 WRITE(numout,*) ' sponge coefficient for tracers = ', visc_tra 373 WRITE(numout,*) ' sponge coefficient for dynamics = ', visc_dyn 374 ENDIF 375 376 END SUBROUTINE agrif_sponge_init 377 378 SUBROUTINE interptn(tabres,i1,i2,j1,j2,k1,k2) 379 !!--------------------------------------------- 380 !! *** ROUTINE interptn *** 381 !!--------------------------------------------- 397 382 # include "domzgr_substitute.h90" 398 integer i1,i2,j1,j2,k1,k2 399 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 400 401 tabres(i1:i2,j1:j2,k1:k2) = tn(i1:i2,j1:j2,k1:k2) 402 403 end subroutine interptn 404 405 subroutine interpsn(tabres,i1,i2,j1,j2,k1,k2) 406 Implicit none 383 384 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 385 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 386 387 tabres(i1:i2,j1:j2,k1:k2) = tn(i1:i2,j1:j2,k1:k2) 388 389 END SUBROUTINE interptn 390 391 SUBROUTINE interpsn(tabres,i1,i2,j1,j2,k1,k2) 392 !!--------------------------------------------- 393 !! *** ROUTINE interpsn *** 394 !!--------------------------------------------- 407 395 # include "domzgr_substitute.h90" 408 integer i1,i2,j1,j2,k1,k2 409 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 410 411 tabres(i1:i2,j1:j2,k1:k2) = sn(i1:i2,j1:j2,k1:k2) 412 413 end subroutine interpsn 414 415 416 subroutine interpun(tabres,i1,i2,j1,j2,k1,k2) 417 Implicit none 396 397 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 398 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 399 400 tabres(i1:i2,j1:j2,k1:k2) = sn(i1:i2,j1:j2,k1:k2) 401 402 END SUBROUTINE interpsn 403 404 405 SUBROUTINE interpun(tabres,i1,i2,j1,j2,k1,k2) 406 !!--------------------------------------------- 407 !! *** ROUTINE interpun *** 408 !!--------------------------------------------- 418 409 # include "domzgr_substitute.h90" 419 integer i1,i2,j1,j2,k1,k2 420 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 421 422 tabres(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2) 423 424 end subroutine interpun 425 426 subroutine interpvn(tabres,i1,i2,j1,j2,k1,k2) 427 Implicit none 410 411 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 412 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 413 414 tabres(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2) 415 416 END SUBROUTINE interpun 417 418 SUBROUTINE interpvn(tabres,i1,i2,j1,j2,k1,k2) 419 !!--------------------------------------------- 420 !! *** ROUTINE interpvn *** 421 !!--------------------------------------------- 428 422 # include "domzgr_substitute.h90" 429 integer i1,i2,j1,j2,k1,k2 430 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 431 432 tabres(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2) 433 434 end subroutine interpvn 423 424 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 425 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 426 427 tabres(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2) 428 429 END SUBROUTINE interpvn 435 430 436 431 #else 437 CONTAINS 438 subroutine agrif_opa_sponge_empty 439 end subroutine agrif_opa_sponge_empty 440 #endif 441 442 End Module agrif_opa_sponge 432 CONTAINS 433 434 SUBROUTINE agrif_opa_sponge_empty 435 !!--------------------------------------------- 436 !! *** ROUTINE agrif_OPA_sponge_empty *** 437 !!--------------------------------------------- 438 WRITE(*,*) 'agrif_opa_sponge : You should not have seen this print! error?' 439 END SUBROUTINE agrif_opa_sponge_empty 440 #endif 441 442 END MODULE agrif_opa_sponge -
trunk/NEMO/NST_SRC/agrif_opa_update.F90
r469 r636 1 1 #define TWO_WAY 2 2 3 Moduleagrif_opa_update3 MODULE agrif_opa_update 4 4 #if defined key_agrif 5 USE par_oce 6 USE oce 7 USE dom_oce 8 9 Integer, Parameter :: nbclineupdate = 3 10 Integer :: nbcline 11 12 Contains 13 14 Subroutine Agrif_Update_Tra( kt ) 15 ! 16 ! Modules used: 17 ! 18 19 implicit none 20 ! 21 ! Declarations: 22 INTEGER :: kt 23 ! 24 ! 25 ! Variables 26 ! 27 Real :: tabtemp(jpi,jpj,jpk) 28 ! 29 ! Begin 30 ! 31 32 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 5 USE par_oce 6 USE oce 7 USE dom_oce 8 9 IMPLICIT NONE 10 PRIVATE 11 12 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 13 14 INTEGER, PARAMETER :: nbclineupdate = 3 15 INTEGER :: nbcline 16 17 CONTAINS 18 19 SUBROUTINE Agrif_Update_Tra( kt ) 20 !!--------------------------------------------- 21 !! *** ROUTINE Agrif_Update_Tra *** 22 !!--------------------------------------------- 23 INTEGER, INTENT(in) :: kt 24 25 REAL :: ztab(jpi,jpj,jpk) 26 27 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 33 28 #if defined TWO_WAY 34 29 Agrif_UseSpecialValueInUpdate = .TRUE. 35 30 Agrif_SpecialValueFineGrid = 0. 36 IF (mod(nbcline,nbclineupdate) == 0) THEN 37 Call Agrif_Update_Variable(tabtemp,tn, procname=updateT)38 Call Agrif_Update_Variable(tabtemp,sn, procname=updateS)39 ELSE40 Call Agrif_Update_Variable(tabtemp,tn,locupdate=(/0,2/), procname=updateT)41 Call Agrif_Update_Variable(tabtemp,sn,locupdate=(/0,2/), procname=updateS)42 ENDIF43 31 32 IF (MOD(nbcline,nbclineupdate) == 0) THEN 33 CALL Agrif_Update_Variable(ztab,tn, procname=updateT) 34 CALL Agrif_Update_Variable(ztab,sn, procname=updateS) 35 ELSE 36 CALL Agrif_Update_Variable(ztab,tn,locupdate=(/0,2/), procname=updateT) 37 CALL Agrif_Update_Variable(ztab,sn,locupdate=(/0,2/), procname=updateS) 38 ENDIF 44 39 45 40 Agrif_UseSpecialValueInUpdate = .FALSE. 46 41 #endif 47 42 48 Return 49 End subroutine Agrif_Update_Tra 50 51 Subroutine Agrif_Update_Dyn( kt ) 52 ! 53 ! Modules used: 54 ! 55 ! 56 ! Declarations: 57 ! 58 INTEGER :: kt 59 ! 60 ! Variables 61 ! 62 Real :: tabtemp(jpi,jpj,jpk) 63 Real :: tabtemp2d(jpi,jpj) 64 ! 65 ! Begin 66 ! 67 ! 43 END SUBROUTINE Agrif_Update_Tra 44 45 SUBROUTINE Agrif_Update_Dyn( kt ) 46 !!--------------------------------------------- 47 !! *** ROUTINE Agrif_Update_Dyn *** 48 !!--------------------------------------------- 49 INTEGER, INTENT(in) :: kt 50 51 REAL(wp), DIMENSION(jpi,jpj) :: ztab2d 52 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztab 53 68 54 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 69 55 #if defined TWO_WAY 70 56 71 57 IF (mod(nbcline,nbclineupdate) == 0) THEN 72 Call Agrif_Update_Variable(tabtemp,un,procname = updateU)73 Call Agrif_Update_Variable(tabtemp,vn,procname = updateV)74 ELSE 75 Call Agrif_Update_Variable(tabtemp,un,locupdate=(/0,1/),procname = updateU)76 Call Agrif_Update_Variable(tabtemp,vn,locupdate=(/0,1/),procname = updateV)77 ENDIF 78 79 C all Agrif_Update_Variable(tabtemp2d,e1u,procname = updateU2d)80 C all Agrif_Update_Variable(tabtemp2d,e2v,procname = updateV2d)81 58 CALL Agrif_Update_Variable(ztab,un,procname = updateU) 59 CALL Agrif_Update_Variable(ztab,vn,procname = updateV) 60 ELSE 61 CALL Agrif_Update_Variable(ztab,un,locupdate=(/0,1/),procname = updateU) 62 CALL Agrif_Update_Variable(ztab,vn,locupdate=(/0,1/),procname = updateV) 63 ENDIF 64 65 CALL Agrif_Update_Variable(ztab2d,e1u,procname = updateU2d) 66 CALL Agrif_Update_Variable(ztab2d,e2v,procname = updateV2d) 67 82 68 nbcline = nbcline + 1 83 69 84 Agrif_UseSpecialValueInUpdate = .TRUE. 85 Agrif_SpecialValueFineGrid = 0. 86 Call Agrif_Update_Variable(tabtemp2d,sshn,procname = updateSSH) 87 Agrif_UseSpecialValueInUpdate = .FALSE. 88 89 90 Call Agrif_ChildGrid_To_ParentGrid() 91 Call recompute_diags( kt ) 92 Call Agrif_ParentGrid_To_ChildGrid() 93 94 #endif 95 ! 96 Return 97 End subroutine Agrif_Update_Dyn 98 99 Subroutine recompute_diags(kt) 100 Use divcur 101 Use wzvmod 102 Use cla_div 103 Use ocfzpt 104 Implicit None 105 INTEGER kt 106 70 Agrif_UseSpecialValueInUpdate = .TRUE. 71 Agrif_SpecialValueFineGrid = 0. 72 CALL Agrif_Update_Variable(ztab2d,sshn,procname = updateSSH) 73 Agrif_UseSpecialValueInUpdate = .FALSE. 74 75 76 CALL Agrif_ChildGrid_To_ParentGrid() 77 CALL recompute_diags( kt ) 78 CALL Agrif_ParentGrid_To_ChildGrid() 79 80 #endif 81 82 END SUBROUTINE Agrif_Update_Dyn 83 84 SUBROUTINE recompute_diags( kt ) 85 !!--------------------------------------------- 86 !! *** ROUTINE recompute_diags *** 87 !!--------------------------------------------- 88 USE divcur 89 USE wzvmod 90 USE cla_div 91 USE ocfzpt 92 93 INTEGER, INTENT(in) :: kt 94 107 95 ta = hdivb 108 96 sa = rotb … … 114 102 115 103 IF( n_cla == 1 ) CALL div_cla( kt ) 116 Call wzv( kt ) 117 118 End Subroutine recompute_diags 119 120 subroutine updateT(tabres,i1,i2,j1,j2,k1,k2,before) 121 Implicit none 122 # include "domzgr_substitute.h90" 123 integer i1,i2,j1,j2,k1,k2 124 integer ji,jj,jk 125 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 126 LOGICAL :: before 127 128 IF (before) THEN 129 130 DO jk=k1,k2 131 DO jj=j1,j2 132 DO ji=i1,i2 133 tabres(ji,jj,jk) = tn(ji,jj,jk) 134 ENDDO 135 ENDDO 136 ENDDO 137 138 ELSE 139 140 DO jk=k1,k2 141 DO jj=j1,j2 142 DO ji=i1,i2 143 IF (tabres(ji,jj,jk).NE.0.) THEN 144 tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 104 CALL wzv( kt ) 105 106 END SUBROUTINE recompute_diags 107 108 SUBROUTINE updateT( tabres, i1, i2, j1, j2, k1, k2, before ) 109 !!--------------------------------------------- 110 !! *** ROUTINE updateT *** 111 !!--------------------------------------------- 112 # include "domzgr_substitute.h90" 113 114 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 115 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 116 LOGICAL, iNTENT(in) :: before 117 118 INTEGER :: ji,jj,jk 119 120 IF (before) THEN 121 DO jk=k1,k2 122 DO jj=j1,j2 123 DO ji=i1,i2 124 tabres(ji,jj,jk) = tn(ji,jj,jk) 125 END DO 126 END DO 127 END DO 128 ELSE 129 DO jk=k1,k2 130 DO jj=j1,j2 131 DO ji=i1,i2 132 IF( tabres(ji,jj,jk) .NE. 0. ) THEN 133 tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 134 ENDIF 135 END DO 136 END DO 137 END DO 138 ENDIF 139 140 END SUBROUTINE updateT 141 142 SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before ) 143 !!--------------------------------------------- 144 !! *** ROUTINE updateS *** 145 !!--------------------------------------------- 146 # include "domzgr_substitute.h90" 147 148 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 149 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 150 LOGICAL, iNTENT(in) :: before 151 152 INTEGER :: ji,jj,jk 153 154 IF (before) THEN 155 DO jk=k1,k2 156 DO jj=j1,j2 157 DO ji=i1,i2 158 tabres(ji,jj,jk) = sn(ji,jj,jk) 159 END DO 160 END DO 161 END DO 162 ELSE 163 DO jk=k1,k2 164 DO jj=j1,j2 165 DO ji=i1,i2 166 IF (tabres(ji,jj,jk).NE.0.) THEN 167 sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 168 ENDIF 169 END DO 170 END DO 171 END DO 172 ENDIF 173 174 END SUBROUTINE updateS 175 176 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before ) 177 !!--------------------------------------------- 178 !! *** ROUTINE updateu *** 179 !!--------------------------------------------- 180 # include "domzgr_substitute.h90" 181 182 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 183 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 184 LOGICAL, INTENT(in) :: before 185 186 INTEGER :: ji, jj, jk 187 REAL(wp) :: zrhoy 188 189 IF (before) THEN 190 zrhoy = Agrif_Rhoy() 191 DO jk=k1,k2 192 DO jj=j1,j2 193 DO ji=i1,i2 194 tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 195 #if ! defined key_zco 196 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk) 197 #endif 198 END DO 199 END DO 200 END DO 201 tabres = zrhoy * tabres 202 ELSE 203 DO jk=k1,k2 204 DO jj=j1,j2 205 DO ji=i1,i2 206 un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj)) 207 un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk) 208 #if ! defined key_zco 209 un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk) 210 #endif 211 END DO 212 END DO 213 END DO 214 ENDIF 215 216 END SUBROUTINE updateu 217 218 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before ) 219 !!--------------------------------------------- 220 !! *** ROUTINE updatev *** 221 !!--------------------------------------------- 222 # include "domzgr_substitute.h90" 223 224 INTEGER :: i1,i2,j1,j2,k1,k2 225 INTEGER :: ji,jj,jk 226 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 227 LOGICAL :: before 228 229 REAL(wp) :: zrhox 230 231 IF (before) THEN 232 zrhox = Agrif_Rhox() 233 DO jk=k1,k2 234 DO jj=j1,j2 235 DO ji=i1,i2 236 tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 237 #if ! defined key_zco 238 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk) 239 #endif 240 END DO 241 END DO 242 END DO 243 tabres = zrhox * tabres 244 ELSE 245 DO jk=k1,k2 246 DO jj=j1,j2 247 DO ji=i1,i2 248 vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj)) 249 vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk) 250 #if ! defined key_zco 251 vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk) 252 #endif 253 END DO 254 END DO 255 END DO 256 ENDIF 257 258 END SUBROUTINE updatev 259 260 SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before ) 261 !!--------------------------------------------- 262 !! *** ROUTINE updateu2d *** 263 !!--------------------------------------------- 264 # include "domzgr_substitute.h90" 265 266 INTEGER, INTENT(in) :: i1, i2, j1, j2 267 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 268 LOGICAL, INTENT(in) :: before 269 270 INTEGER :: ji, jj, jk 271 REAL(wp) :: zrhoy 272 REAL(wp) :: zhinv 273 274 IF (before) THEN 275 zrhoy = Agrif_Rhoy() 276 DO jk = 1,jpkm1 277 DO jj=j1,j2 278 DO ji=i1,i2 279 tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk) 280 END DO 281 END DO 282 END DO 283 DO jj=j1,j2 284 DO ji=i1,i2 285 tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj) 286 END DO 287 END DO 288 tabres = zrhoy * tabres 289 ELSE 290 DO jj=j1,j2 291 DO ji=i1,i2 292 IF(umask(ji,jj,1) .NE. 0.) THEN 293 spgu(ji,jj) = 0.e0 294 DO jk=1,jpk 295 spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk) 296 END DO 297 spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj) 298 zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj)) 299 Do jk=1,jpk 300 un(ji,jj,jk) = un(ji,jj,jk) + zhinv 301 un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk) 302 END DO 145 303 ENDIF 146 ENDDO 147 ENDDO 148 ENDDO 149 ENDIF 150 151 end subroutine updateT 152 153 154 subroutine updateS(tabres,i1,i2,j1,j2,k1,k2,before) 155 Implicit none 156 # include "domzgr_substitute.h90" 157 integer i1,i2,j1,j2,k1,k2 158 integer ji,jj,jk 159 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 160 LOGICAL :: before 161 162 163 IF (before) THEN 164 165 DO jk=k1,k2 166 DO jj=j1,j2 167 DO ji=i1,i2 168 tabres(ji,jj,jk) = sn(ji,jj,jk) 169 ENDDO 170 ENDDO 171 ENDDO 172 173 ELSE 174 175 DO jk=k1,k2 176 DO jj=j1,j2 177 DO ji=i1,i2 178 IF (tabres(ji,jj,jk).NE.0.) THEN 179 sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 304 END DO 305 END DO 306 ENDIF 307 308 END SUBROUTINE updateu2d 309 310 SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before ) 311 !!--------------------------------------------- 312 !! *** ROUTINE updatev2d *** 313 !!--------------------------------------------- 314 315 INTEGER, INTENT(in) :: i1, i2, j1, j2 316 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 317 LOGICAL, INTENT(in) :: before 318 319 INTEGER :: ji, jj, jk 320 REAL(wp) :: zrhox 321 REAL(wp) :: zhinv 322 323 IF (before) THEN 324 zrhox = Agrif_Rhox() 325 tabres = 0.e0 326 DO jk = 1,jpkm1 327 DO jj=j1,j2 328 DO ji=i1,i2 329 tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk) 330 END DO 331 END DO 332 END DO 333 DO jj=j1,j2 334 DO ji=i1,i2 335 tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj) 336 END DO 337 END DO 338 tabres = zrhox * tabres 339 ELSE 340 DO jj=j1,j2 341 DO ji=i1,i2 342 IF(vmask(ji,jj,1) .NE. 0.) THEN 343 spgv(ji,jj) = 0. 344 DO jk=1,jpk 345 spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk) 346 END DO 347 spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj) 348 zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj)) 349 DO jk=1,jpk 350 vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv 351 vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk) 352 END DO 180 353 ENDIF 181 ENDDO 182 ENDDO 183 ENDDO 184 ENDIF 185 186 end subroutine updateS 187 188 subroutine updateu(tabres,i1,i2,j1,j2,k1,k2,before) 189 Implicit none 190 # include "domzgr_substitute.h90" 191 integer i1,i2,j1,j2,k1,k2 192 integer ji,jj,jk 193 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 194 LOGICAL :: before 195 REAL(wp) :: rhoy 196 197 198 IF (before) THEN 199 200 rhoy = Agrif_Rhoy() 201 202 DO jk=k1,k2 203 DO jj=j1,j2 204 DO ji=i1,i2 205 tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 206 #if ! defined key_zco 207 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk) 208 #endif 209 ENDDO 210 ENDDO 211 ENDDO 212 213 tabres = rhoy * tabres 214 215 ELSE 216 217 DO jk=k1,k2 218 DO jj=j1,j2 219 DO ji=i1,i2 220 un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj)) 221 un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk) 222 #if ! defined key_zco 223 un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk) 224 #endif 225 ENDDO 226 ENDDO 227 ENDDO 228 ENDIF 229 230 end subroutine updateu 231 232 subroutine updatev(tabres,i1,i2,j1,j2,k1,k2,before) 233 Implicit none 234 # include "domzgr_substitute.h90" 235 integer i1,i2,j1,j2,k1,k2 236 integer ji,jj,jk 237 real,dimension(i1:i2,j1:j2,k1:k2) :: tabres 238 LOGICAL :: before 239 REAL(wp) :: rhox 240 241 242 IF (before) THEN 243 244 rhox = Agrif_Rhox() 245 246 DO jk=k1,k2 247 DO jj=j1,j2 248 DO ji=i1,i2 249 tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 250 #if ! defined key_zco 251 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk) 252 #endif 253 ENDDO 254 ENDDO 255 ENDDO 256 257 tabres = rhox * tabres 258 259 ELSE 260 261 DO jk=k1,k2 262 DO jj=j1,j2 263 DO ji=i1,i2 264 vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj)) 265 vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk) 266 #if ! defined key_zco 267 vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk) 268 #endif 269 ENDDO 270 ENDDO 271 ENDDO 272 ENDIF 273 274 end subroutine updatev 275 276 subroutine updateu2d(tabres,i1,i2,j1,j2,before) 277 Implicit none 278 # include "domzgr_substitute.h90" 279 integer i1,i2,j1,j2 280 integer ji,jj,jk 281 real,dimension(i1:i2,j1:j2) :: tabres 282 LOGICAL :: before 283 REAL(wp) :: rhoy 284 REAL(wp) :: hinv 285 286 287 IF (before) THEN 288 289 rhoy = Agrif_Rhoy() 290 291 DO jk = 1,jpkm1 292 DO jj=j1,j2 293 DO ji=i1,i2 294 tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk) 295 ENDDO 296 ENDDO 297 ENDDO 298 299 DO jj=j1,j2 300 DO ji=i1,i2 301 tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj) 302 ENDDO 303 ENDDO 304 305 tabres = rhoy * tabres 306 307 ELSE 308 309 DO jj=j1,j2 310 DO ji=i1,i2 311 IF (umask(ji,jj,1) .NE. 0.) THEN 312 spgu(ji,jj) = 0. 313 Do jk=1,jpk 314 spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk) 315 EndDo 316 spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj) 317 hinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj)) 318 Do jk=1,jpk 319 un(ji,jj,jk) = un(ji,jj,jk) + hinv 320 un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk) 321 EndDo 322 ENDIF 323 ENDDO 324 ENDDO 325 ENDIF 326 327 end subroutine updateu2d 328 329 subroutine updatev2d(tabres,i1,i2,j1,j2,before) 330 Implicit none 331 integer i1,i2,j1,j2 332 integer ji,jj,jk 333 real,dimension(i1:i2,j1:j2) :: tabres 334 LOGICAL :: before 335 REAL(wp) :: rhox 336 REAL(wp) :: hinv 337 338 339 IF (before) THEN 340 341 rhox = Agrif_Rhox() 342 343 tabres = 0. 344 345 DO jk = 1,jpkm1 346 DO jj=j1,j2 347 DO ji=i1,i2 348 tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk) 349 ENDDO 350 ENDDO 351 ENDDO 352 353 DO jj=j1,j2 354 DO ji=i1,i2 355 tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj) 356 ENDDO 357 ENDDO 358 359 tabres = rhox * tabres 360 361 ELSE 362 363 DO jj=j1,j2 364 DO ji=i1,i2 365 IF (vmask(ji,jj,1) .NE. 0.) THEN 366 spgv(ji,jj) = 0. 367 Do jk=1,jpk 368 spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk) 369 EndDo 370 spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj) 371 hinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj)) 372 373 Do jk=1,jpk 374 vn(ji,jj,jk) = vn(ji,jj,jk) + hinv 375 vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk) 376 EndDo 377 ENDIF 378 ENDDO 379 ENDDO 380 381 ENDIF 382 383 end subroutine updatev2d 384 385 subroutine updateSSH(tabres,i1,i2,j1,j2,before) 386 Implicit none 387 # include "domzgr_substitute.h90" 388 integer i1,i2,j1,j2 389 integer ji,jj 390 real,dimension(i1:i2,j1:j2) :: tabres 391 LOGICAL :: before 392 REAL(wp) :: rhox, rhoy 393 394 395 IF (before) THEN 396 rhox = Agrif_Rhox() 397 rhoy = Agrif_Rhoy() 398 399 DO jj=j1,j2 400 DO ji=i1,i2 354 END DO 355 END DO 356 ENDIF 357 358 END SUBROUTINE updatev2d 359 360 SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 361 !!--------------------------------------------- 362 !! *** ROUTINE updateSSH *** 363 !!--------------------------------------------- 364 # include "domzgr_substitute.h90" 365 366 INTEGER, INTENT(in) :: i1, i2, j1, j2 367 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 368 LOGICAL, INTENT(in) :: before 369 370 INTEGER :: ji, jj 371 REAL(wp) :: zrhox, zrhoy 372 373 IF (before) THEN 374 zrhox = Agrif_Rhox() 375 zrhoy = Agrif_Rhoy() 376 DO jj=j1,j2 377 DO ji=i1,i2 401 378 tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj) 402 ENDDO 403 ENDDO 404 405 tabres = rhox * rhoy * tabres 406 407 ELSE 408 DO jj=j1,j2 409 DO ji=i1,i2 379 END DO 380 END DO 381 tabres = zrhox * zrhoy * tabres 382 ELSE 383 DO jj=j1,j2 384 DO ji=i1,i2 410 385 sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj)) 411 386 sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1) 412 ENDDO413 ENDDO414 415 416 end subroutineupdateSSH417 387 END DO 388 END DO 389 ENDIF 390 391 END SUBROUTINE updateSSH 392 418 393 #else 419 CONTAINS 420 subroutine agrif_opa_update_empty 421 end subroutine agrif_opa_update_empty 422 #endif 423 End Module agrif_opa_update 394 CONTAINS 395 SUBROUTINE agrif_opa_update_empty 396 !!--------------------------------------------- 397 !! *** ROUTINE agrif_opa_update_empty *** 398 !!--------------------------------------------- 399 WRITE(*,*) 'agrif_opa_update : You should not have seen this print! error?' 400 END SUBROUTINE agrif_opa_update_empty 401 #endif 402 END MODULE agrif_opa_update -
trunk/NEMO/NST_SRC/agrif_top_interp.F90
r628 r636 1 ! 2 Module agrif_top_interp 1 MODULE agrif_top_interp 3 2 #if defined key_agrif && defined key_passivetrc 4 5 6 7 8 USE trc9 3 USE par_oce 4 USE oce 5 USE dom_oce 6 USE sol_oce 7 USE trcstp 8 USE sms 10 9 11 CONTAINS12 SUBROUTINE Agrif_trc( kt )10 IMPLICIT NONE 11 PRIVATE 13 12 14 Implicit none 15 16 !! * Substitutions 13 PUBLIC Agrif_trc 14 15 CONTAINS 16 17 SUBROUTINE Agrif_trc( kt ) 18 !!--------------------------------------------- 19 !! *** ROUTINE Agrif_trc *** 20 !!--------------------------------------------- 17 21 # include "domzgr_substitute.h90" 18 22 # include "vectopt_loop_substitute.h90" 19 ! 20 INTEGER :: kt21 REAL(wp) tratemp(jpi,jpj,jpk,jptra) 23 24 INTEGER, INTENT(in) :: kt 25 22 26 INTEGER :: ji,jj,jk,jn 23 REAL(wp) :: rhox27 REAL(wp) :: zrhox 24 28 REAL(wp) :: alpha1, alpha2, alpha3, alpha4 25 29 REAL(wp) :: alpha5, alpha6, alpha7 26 ! 27 IF (Agrif_Root()) RETURN 30 REAL(wp), DIMENSION(jpi,jpj,jpk,jptra) :: ztra 31 32 IF (Agrif_Root()) RETURN 28 33 29 30 31 tratemp = 0.34 Agrif_SpecialValue=0. 35 Agrif_UseSpecialValue = .TRUE. 36 ztra = 0.e0 32 37 33 Call Agrif_Bc_variable(tratemp,trn) 34 Agrif_UseSpecialValue = .FALSE. 35 36 rhox = Agrif_Rhox() 37 38 alpha1 = (rhox-1.)/2. 39 alpha2 = 1.-alpha1 40 41 alpha3 = (rhox-1)/(rhox+1) 42 alpha4 = 1.-alpha3 43 44 alpha6 = 2.*(rhox-1.)/(rhox+1.) 45 alpha7 = -(rhox-1)/(rhox+3) 46 alpha5 = 1. - alpha6 - alpha7 47 48 ! 49 If ((nbondi == 1).OR.(nbondi == 2)) THEN 50 51 tra(nlci,:,:,:) = alpha1 * tratemp(nlci,:,:,:) + alpha2 * tratemp(nlci-1,:,:,:) 52 53 Do jn=1,jptra 54 Do jk=1,jpk 55 Do jj=1,jpj 56 IF (umask(nlci-2,jj,jk).EQ.0.) THEN 57 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 58 ELSE 59 tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 60 IF (un(nlci-2,jj,jk).GT.0.) THEN 61 tra(nlci-1,jj,jk,jn)=(alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn) & 62 +alpha7*tra(nlci-3,jj,jk,jn))*tmask(nlci-1,jj,jk) 63 ENDIF 64 ENDIF 65 End Do 66 enddo 67 END DO 68 ENDIF 69 70 If ((nbondj == 1).OR.(nbondj == 2)) THEN 71 72 tra(:,nlcj,:,:) = alpha1 * tratemp(:,nlcj,:,:) + alpha2 * tratemp(:,nlcj-1,:,:) 73 74 DO jn=1, jptra 75 Do jk=1,jpk 76 Do ji=1,jpi 77 IF (vmask(ji,nlcj-2,jk).EQ.0.) THEN 78 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 79 ELSE 80 tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 81 IF (vn(ji,nlcj-2,jk) .GT. 0.) THEN 82 tra(ji,nlcj-1,jk,jn)=(alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn) & 83 +alpha7*tra(ji,nlcj-3,jk,jn))*tmask(ji,nlcj-1,jk) 84 ENDIF 85 ENDIF 86 End Do 87 enddo 88 END DO 38 CALL Agrif_Bc_variable(ztra,trn) 39 Agrif_UseSpecialValue = .FALSE. 40 41 zrhox = Agrif_Rhox() 42 43 alpha1 = (zrhox-1.)/2. 44 alpha2 = 1.-alpha1 45 46 alpha3 = (zrhox-1)/(zrhox+1) 47 alpha4 = 1.-alpha3 48 49 alpha6 = 2.*(zrhox-1.)/(zrhox+1.) 50 alpha7 = -(zrhox-1)/(zrhox+3) 51 alpha5 = 1. - alpha6 - alpha7 52 53 IF ((nbondi == 1).OR.(nbondi == 2)) THEN 54 tra(nlci,:,:,:) = alpha1 * ztra(nlci,:,:,:) + alpha2 * ztra(nlci-1,:,:,:) 55 DO jn=1,jptra 56 DO jk=1,jpk 57 DO jj=1,jpj 58 IF (umask(nlci-2,jj,jk).EQ.0.) THEN 59 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 60 ELSE 61 tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 62 IF (un(nlci-2,jj,jk).GT.0.) THEN 63 tra(nlci-1,jj,jk,jn)=(alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn) & 64 +alpha7*tra(nlci-3,jj,jk,jn))*tmask(nlci-1,jj,jk) 65 ENDIF 66 ENDIF 67 END DO 68 END DO 69 END DO 70 ENDIF 71 72 IF ((nbondj == 1).OR.(nbondj == 2)) THEN 73 tra(:,nlcj,:,:) = alpha1 * ztra(:,nlcj,:,:) + alpha2 * ztra(:,nlcj-1,:,:) 74 DO jn=1, jptra 75 DO jk=1,jpk 76 DO ji=1,jpi 77 IF (vmask(ji,nlcj-2,jk).EQ.0.) THEN 78 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 79 ELSE 80 tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 81 IF (vn(ji,nlcj-2,jk) .GT. 0.) THEN 82 tra(ji,nlcj-1,jk,jn)=(alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn) & 83 +alpha7*tra(ji,nlcj-3,jk,jn))*tmask(ji,nlcj-1,jk) 84 ENDIF 85 ENDIF 86 END DO 87 END DO 88 END DO 89 89 ENDIF 90 90 91 91 IF ((nbondi == -1).OR.(nbondi == 2)) THEN 92 93 tra(1,:,:,:) = alpha1 * tratemp(1,:,:,:) + alpha2 * tratemp(2,:,:,:) 94 95 DO jn=1, jptra 96 Do jk=1,jpk 97 Do jj=1,jpj 98 IF (umask(2,jj,jk).EQ.0.) THEN 99 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 100 ELSE 101 tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 102 IF (un(2,jj,jk).LT.0.) THEN 103 tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn) & 92 tra(1,:,:,:) = alpha1 * ztra(1,:,:,:) + alpha2 * ztra(2,:,:,:) 93 DO jn=1, jptra 94 DO jk=1,jpk 95 DO jj=1,jpj 96 IF (umask(2,jj,jk).EQ.0.) THEN 97 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 98 ELSE 99 tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 100 IF (un(2,jj,jk).LT.0.) THEN 101 tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn) & 104 102 +alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 105 ENDIF 106 ENDIF 107 End Do 108 enddo 109 END DO 110 ENDIF 111 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 112 113 tra(:,1,:,:) = alpha1 * tratemp(:,1,:,:) + alpha2 * tratemp(:,2,:,:) 114 115 DO jn=1, jptra 116 Do jk=1,jpk 117 Do ji=1,jpi 118 IF (vmask(ji,2,jk).EQ.0.) THEN 119 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 120 ELSE 121 tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 122 IF (vn(ji,2,jk) .LT. 0.) THEN 123 tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)& 124 +alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 125 ENDIF 126 ENDIF 127 End Do 128 enddo 129 END DO 103 ENDIF 104 ENDIF 105 END DO 106 END DO 107 END DO 130 108 ENDIF 131 109 132 End Subroutine Agrif_trc 133 ! 134 ! 110 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 111 tra(:,1,:,:) = alpha1 * ztra(:,1,:,:) + alpha2 * ztra(:,2,:,:) 112 DO jn=1, jptra 113 DO jk=1,jpk 114 DO ji=1,jpi 115 IF (vmask(ji,2,jk).EQ.0.) THEN 116 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 117 ELSE 118 tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 119 IF (vn(ji,2,jk) .LT. 0.) THEN 120 tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)& 121 +alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 122 ENDIF 123 ENDIF 124 END DO 125 END DO 126 END DO 127 ENDIF 135 128 129 END SUBROUTINE Agrif_trc 136 130 137 131 #else 138 CONTAINS 139 subroutine Agrif_TOP_Interp_empty 132 CONTAINS 133 SUBROUTINE Agrif_TOP_Interp_empty 134 !!--------------------------------------------- 135 !! *** ROUTINE agrif_Top_Interp_empty *** 136 !!--------------------------------------------- 137 WRITE(*,*) 'agrif_top_interp : You should not have seen this print! error?' 138 END SUBROUTINE Agrif_TOP_Interp_empty 139 #endif 140 END MODULE agrif_top_interp 140 141 141 end subroutine Agrif_TOP_Interp_empty142 #endif143 End Module agrif_top_interp144 -
trunk/NEMO/NST_SRC/agrif_top_update.F90
r628 r636 1 1 #define TWO_WAY 2 2 3 Module agrif_top_update 3 MODULE agrif_top_update 4 4 5 #if defined key_agrif && defined key_passivetrc 5 USE par_oce 6 USE oce 7 USE dom_oce 8 USE trc 9 USE sms 10 11 Integer, Parameter :: nbclineupdate = 3 12 Integer :: nbcline 6 USE par_oce 7 USE oce 8 USE dom_oce 9 USE trcstp 10 USE sms 13 11 14 Contains 12 IMPLICIT NONE 13 PRIVATE 15 14 16 Subroutine Agrif_Update_Trc( kt ) 17 ! 18 ! Modules used: 19 ! 15 PUBLIC Agrif_Update_Trc 20 16 21 implicit none 22 ! 23 ! Declarations: 24 INTEGER :: kt 25 ! 26 ! 27 ! Variables 28 ! 29 Real :: tabtemp(jpi,jpj,jpk,jptra) 30 ! 31 ! Begin 32 ! 17 INTEGER, PARAMETER :: nbclineupdate = 3 18 INTEGER :: nbcline 33 19 34 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 35 #if defined TWO_WAYxiv8 20 CONTAINS 21 22 SUBROUTINE Agrif_Update_Trc( kt ) 23 !!--------------------------------------------- 24 !! *** ROUTINE Agrif_Update_Trc *** 25 !!--------------------------------------------- 26 INTEGER, INTENT(in) :: kt 27 28 REAL(wp), DIMENSION(jpi,jpj,jpk,jptra) :: ztra 29 30 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 31 32 #if defined TWO_WAY 36 33 Agrif_UseSpecialValueInUpdate = .TRUE. 37 34 Agrif_SpecialValueFineGrid = 0. 38 IF (mod(nbcline,nbclineupdate) == 0) THEN 39 Call Agrif_Update_Variable(tabtemp,trn, procname=updateTRC) 35 36 IF (MOD(nbcline,nbclineupdate) == 0) THEN 37 CALL Agrif_Update_Variable(ztra,trn, procname=updateTRC) 40 38 ELSE 41 Call Agrif_Update_Variable(tabtemp,trn,locupdate=(/0,2/), procname=updateTRC)39 CALL Agrif_Update_Variable(ztra,trn,locupdate=(/0,2/), procname=updateTRC) 42 40 ENDIF 43 44 41 45 42 Agrif_UseSpecialValueInUpdate = .FALSE. 46 43 #endif 47 44 48 End subroutineAgrif_Update_Trc45 END SUBROUTINE Agrif_Update_Trc 49 46 47 SUBROUTINE updateTRC(tabres,i1,i2,j1,j2,k1,k2,before) 48 !!--------------------------------------------- 49 !! *** ROUTINE UpdateTrc *** 50 !!--------------------------------------------- 51 # include "domzgr_substitute.h90" 50 52 51 subroutine updateTRC(tabres,i1,i2,j1,j2,k1,k2,before) 52 Implicit none 53 # include "domzgr_substitute.h90" 54 integer i1,i2,j1,j2,k1,k2 55 integer ji,jj,jk,jn 56 real,dimension(i1:i2,j1:j2,k1:k2,jptra) :: tabres 57 LOGICAL :: before 53 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 54 REAL, DIMENSION(i1:i2,j1:j2,k1:k2,jptra), INTENT(inout) :: tabres 55 LOGICAL, INTENT(in) :: before 56 57 INTEGER :: ji,jj,jk,jn 58 58 59 DO jn=1, jptra 60 IF (before) THEN 61 62 DO jk=k1,k2 63 DO jj=j1,j2 64 DO ji=i1,i2 65 tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 66 ENDDO 67 ENDDO 68 ENDDO 69 70 ELSE 59 DO jn=1, jptra 71 60 72 DO jk=k1,k273 DO jj=j1,j274 DO ji=i1,i275 IF (tabres(ji,jj,jk,jn).NE.0.) THEN76 trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk)77 ENDIF78 ENDDO61 IF (before) THEN 62 DO jk=k1,k2 63 DO jj=j1,j2 64 DO ji=i1,i2 65 tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 66 ENDDO 67 ENDDO 79 68 ENDDO 80 ENDDO 81 ENDIF 69 ELSE 70 DO jk=k1,k2 71 DO jj=j1,j2 72 DO ji=i1,i2 73 IF (tabres(ji,jj,jk,jn).NE.0.) THEN 74 trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 75 ENDIF 76 ENDDO 77 ENDDO 78 ENDDO 79 ENDIF 82 80 83 END DO 84 85 end subroutine updateTRC 81 END DO 86 82 87 83 END SUBROUTINE updateTRC 88 84 89 90 85 #else 91 CONTAINS 92 subroutine agrif_top_update_empty 93 end subroutine agrif_top_update_empty 86 CONTAINS 87 SUBROUTINE agrif_top_update_empty 88 !!--------------------------------------------- 89 !! *** ROUTINE agrif_Top_update_empty *** 90 !!--------------------------------------------- 91 WRITE(*,*) 'agrif_top_update : You should not have seen this print! error?' 92 END SUBROUTINE agrif_top_update_empty 94 93 #endif 95 EndModule agrif_top_update94 END Module agrif_top_update -
trunk/NEMO/NST_SRC/agrif_user.F90
r628 r636 1 1 #if defined key_agrif 2 3 ! 4 ! Modules used: 5 ! 6 U separ_oce7 U sedom_oce2 SUBROUTINE Agrif_InitWorkspace 3 !!------------------------------------------ 4 !! *** ROUTINE Agrif_InitWorkspace *** 5 !!------------------------------------------ 6 USE par_oce 7 USE dom_oce 8 8 USE Agrif_Util 9 ! 10 ! Declarations: 11 ! 9 12 10 IMPLICIT NONE 13 ! 14 ! Variables 15 ! 16 17 ! 18 ! Begin 19 ! 20 if ( .NOT. Agrif_Root() ) then 11 12 #if defined key_mpp_dyndist 13 CHARACTER(len=20) :: namelistname 14 INTEGER nummpp 15 NAMELIST/nam_mpp_dyndist/jpni,jpnj,jpnij 16 17 IF (Agrif_Nbstepint() .EQ. 0) THEN 18 nummpp = Agrif_Get_Unit() 19 namelistname='namelist' 20 IF (.NOT. Agrif_Root()) namelistname=TRIM(Agrif_CFixed())//'_namelist' 21 OPEN(nummpp,file=namelistname,status='OLD',form='formatted') 22 READ (nummpp,nam_mpp_dyndist) 23 CLOSE(nummpp) 24 ENDIF 25 #endif 26 27 IF( .NOT. Agrif_Root() ) THEN 21 28 jpiglo = nbcellsx + 2 + 2*nbghostcells 22 29 jpjglo = nbcellsy + 2 + 2*nbghostcells … … 33 40 nperio = 0 34 41 jperio = 0 35 endif 36 37 38 Return 39 End Subroutine Agrif_InitWorkspace 40 41 ! 42 SUBROUTINE Agrif_InitValues 43 ! ------------------------------------------------------------------ 44 ! You should declare the variable which has to be interpolated here 45 ! ----------------------------------------------------------------- 46 ! 47 ! Modules used: 48 ! 42 ENDIF 43 44 END SUBROUTINE Agrif_InitWorkspace 45 46 ! 47 SUBROUTINE Agrif_InitValues 48 !!------------------------------------------ 49 !! *** ROUTINE Agrif_InitValues *** 50 !! 51 !! ** Purpose :: Declaration of variables to 52 !! be interpolated 53 !!------------------------------------------ 49 54 USE Agrif_Util 50 USE oce 55 USE oce 51 56 USE dom_oce 52 57 USE opa 53 #if defined key_tradmp || defined key_esopa 58 USE sms 59 #if defined key_tradmp || defined key_esopa 54 60 USE tradmp 55 61 #endif … … 59 65 USE ice_oce 60 66 #endif 61 #if defined key_passivetrc62 USE agrif_top_update63 USE agrif_top_interp64 USE sms65 #endif66 67 #if defined key_agrif 67 USE agrif_opa_update 68 USE agrif_opa_interp 69 USE agrif_opa_sponge 70 #endif 71 ! 72 ! Declarations: 73 ! 74 Implicit none 75 ! 76 ! Variables 77 ! 78 REAL(wp) tabtemp(jpi,jpj,jpk) 79 #if defined key_passivetrc 80 REAL(wp) tabtrtemp(jpi,jpj,jpk,jptra) 81 #endif 82 ! 68 USE agrif_opa_update 69 USE agrif_opa_interp 70 USE agrif_opa_sponge 71 USE agrif_top_update 72 USE agrif_top_interp 73 #endif 74 75 IMPLICIT NONE 76 77 REAL(wp) :: tabtemp(jpi,jpj,jpk) 78 #if defined key_passivetrc 79 REAL(wp) :: tabtrtemp(jpi,jpj,jpk,jptra) 80 #endif 83 81 LOGICAL check_namelist 84 ! 85 ! 86 ! Begin 87 ! 82 83 ! 0. Initializations 84 !------------------- 88 85 #if defined key_orca_r025 || defined key_orca_r05 || defined key_orca_r2 || defined key_orca_r4 89 jp_cfg = -1 ! set special value for jp_cfg on fine grids86 jp_cfg = -1 ! set special value for jp_cfg on fine grids 90 87 cp_cfg = "default" 91 88 #endif 92 89 93 90 Call opa_init ! Initializations of each fine grid 94 ! 95 ! Specific fine grid Initializations 96 ! 91 92 ! Specific fine grid Initializations 97 93 #if defined key_tradmp || defined key_esopa 98 ! no tracer damping on fine grids94 ! no tracer damping on fine grids 99 95 lk_tradmp = .FALSE. 100 96 #endif 101 ! 102 ! Declaration of the type of variable which have to be interpolated 103 ! 97 ! 1. Declaration of the type of variable which have to be interpolated 98 !--------------------------------------------------------------------- 104 99 Call Agrif_Set_type(un,(/1,2,0/),(/2,3,0/)) 105 100 Call Agrif_Set_type(vn,(/2,1,0/),(/3,2,0/)) … … 110 105 Call Agrif_Set_type(e1u,(/1,2/),(/2,3/)) 111 106 Call Agrif_Set_type(e2v,(/2,1/),(/3,2/)) 112 107 113 108 Call Agrif_Set_type(tn,(/2,2,0/),(/3,3,0/)) 114 109 Call Agrif_Set_type(sn,(/2,2,0/),(/3,3,0/)) … … 116 111 Call Agrif_Set_type(tb,(/2,2,0/),(/3,3,0/)) 117 112 Call Agrif_Set_type(sb,(/2,2,0/),(/3,3,0/)) 118 113 119 114 Call Agrif_Set_type(ta,(/2,2,0/),(/3,3,0/)) 120 115 Call Agrif_Set_type(sa,(/2,2,0/),(/3,3,0/)) 121 116 122 117 Call Agrif_Set_type(sshn,(/2,2/),(/3,3/)) 123 118 Call Agrif_Set_type(gcb,(/2,2/),(/3,3/)) … … 128 123 Call Agrif_Set_type(tra,(/2,2,0,0/),(/3,3,0,0/)) 129 124 #endif 130 131 132 133 ! 134 ! Space directions for each variables 135 ! 125 126 ! 2. Space directions for each variables 127 !--------------------------------------- 136 128 Call Agrif_Set_raf(un,(/'x','y','N'/)) 137 129 Call Agrif_Set_raf(vn,(/'x','y','N'/)) 138 130 139 131 Call Agrif_Set_raf(ua,(/'x','y','N'/)) 140 132 Call Agrif_Set_raf(va,(/'x','y','N'/)) … … 145 137 Call Agrif_Set_raf(tn,(/'x','y','N'/)) 146 138 Call Agrif_Set_raf(sn,(/'x','y','N'/)) 147 139 148 140 Call Agrif_Set_raf(tb,(/'x','y','N'/)) 149 141 Call Agrif_Set_raf(sb,(/'x','y','N'/)) 150 142 151 143 Call Agrif_Set_raf(ta,(/'x','y','N'/)) 152 144 Call Agrif_Set_raf(sa,(/'x','y','N'/)) 153 145 154 146 Call Agrif_Set_raf(sshn,(/'x','y'/)) 155 147 Call Agrif_Set_raf(gcb,(/'x','y'/)) … … 161 153 #endif 162 154 163 ! 164 ! type of interpolation 165 155 ! 3. Type of interpolation 156 !------------------------- 166 157 Call Agrif_Set_bcinterp(tn,interp=AGRIF_linear) 167 158 Call Agrif_Set_bcinterp(sn,interp=AGRIF_linear) 168 159 169 160 Call Agrif_Set_bcinterp(ta,interp=AGRIF_linear) 170 161 Call Agrif_Set_bcinterp(sa,interp=AGRIF_linear) 171 162 172 163 Call Agrif_Set_bcinterp(un,interp1=Agrif_linear,interp2=AGRIF_ppm) 173 164 Call Agrif_Set_bcinterp(vn,interp1=AGRIF_ppm,interp2=Agrif_linear) … … 175 166 Call Agrif_Set_bcinterp(ua,interp1=Agrif_linear,interp2=AGRIF_ppm) 176 167 Call Agrif_Set_bcinterp(va,interp1=AGRIF_ppm,interp2=Agrif_linear) 177 168 178 169 Call Agrif_Set_bcinterp(e1u,interp1=Agrif_linear,interp2=AGRIF_ppm) 179 170 Call Agrif_Set_bcinterp(e2v,interp1=AGRIF_ppm,interp2=Agrif_linear) … … 184 175 #endif 185 176 186 ! 187 ! Location of interpolation 188 ! 177 ! 4. Location of interpolation 178 !----------------------------- 189 179 Call Agrif_Set_bc(un,(/0,1/)) 190 180 Call Agrif_Set_bc(vn,(/0,1/)) 191 181 192 182 Call Agrif_Set_bc(e1u,(/0,0/)) 193 183 Call Agrif_Set_bc(e2v,(/0,0/)) … … 207 197 #endif 208 198 209 !Update type210 199 ! 5. Update type 200 !--------------- 211 201 Call Agrif_Set_Updatetype(tn, update = AGRIF_Update_Average) 212 202 Call Agrif_Set_Updatetype(sn, update = AGRIF_Update_Average) 213 203 214 204 Call Agrif_Set_Updatetype(tb, update = AGRIF_Update_Average) 215 205 Call Agrif_Set_Updatetype(sb, update = AGRIF_Update_Average) … … 229 219 Call Agrif_Set_Updatetype(e2v,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 230 220 231 ! First interpolations of potentially non zero fields 232 233 Agrif_SpecialValue=0. 234 Agrif_UseSpecialValue = .TRUE. 235 Call Agrif_Bc_variable(tabtemp,tn,calledweight=1.) 236 Call Agrif_Bc_variable(tabtemp,sn,calledweight=1.) 237 Call Agrif_Bc_variable(tabtemp,un,calledweight=1.,procname=interpu) 238 Call Agrif_Bc_variable(tabtemp,vn,calledweight=1.,procname=interpv) 239 240 Call Agrif_Bc_variable(tabtemp,ta,calledweight=1.,procname=interptn) 241 Call Agrif_Bc_variable(tabtemp,sa,calledweight=1.,procname=interpsn) 242 243 Call Agrif_Bc_variable(tabtemp,ua,calledweight=1.,procname=interpun) 244 Call Agrif_Bc_variable(tabtemp,va,calledweight=1.,procname=interpvn) 245 246 #if defined key_passivetrc 247 Call Agrif_Bc_variable(tabtrtemp,trn,calledweight=1.) 248 ! Call Agrif_Bc_variable(tabtrtemp,tra,calledweight=1.,procname=interptrn) 249 Call Agrif_Bc_variable(tabtrtemp,tra,calledweight=1.) 250 251 #endif 252 Agrif_UseSpecialValue = .FALSE. 253 254 ! 255 256 ! 221 ! 6. First interpolations of potentially non zero fields 222 !------------------------------------------------------- 223 Agrif_SpecialValue=0. 224 Agrif_UseSpecialValue = .TRUE. 225 Call Agrif_Bc_variable(tabtemp,tn,calledweight=1.) 226 Call Agrif_Bc_variable(tabtemp,sn,calledweight=1.) 227 Call Agrif_Bc_variable(tabtemp,un,calledweight=1.,procname=interpu) 228 Call Agrif_Bc_variable(tabtemp,vn,calledweight=1.,procname=interpv) 229 230 Call Agrif_Bc_variable(tabtemp,ta,calledweight=1.,procname=interptn) 231 Call Agrif_Bc_variable(tabtemp,sa,calledweight=1.,procname=interpsn) 232 233 Call Agrif_Bc_variable(tabtemp,ua,calledweight=1.,procname=interpun) 234 Call Agrif_Bc_variable(tabtemp,va,calledweight=1.,procname=interpvn) 235 236 #if defined key_passivetrc 237 Call Agrif_Bc_variable(tabtrtemp,trn,calledweight=1.) 238 Call Agrif_Bc_variable(tabtrtemp,tra,calledweight=1.) 239 #endif 240 Agrif_UseSpecialValue = .FALSE. 241 242 ! 7. Some controls 243 !----------------- 257 244 check_namelist = .true. 258 ! 259 IF( check_namelist ) then 260 ! 261 ! check time steps 262 ! 263 If( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) then 264 Write(*,*) 'incompatible time step between grids' 265 Write(*,*) 'parent grid value : ',Agrif_Parent(rdt) 266 Write(*,*) 'child grid value : ',nint(rdt) 267 Write(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 268 stop 269 Endif 270 271 If( Agrif_IRhot() * (Agrif_Parent(nitend)- & 272 Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) then 273 Write(*,*) 'incompatible run length between grids' 274 Write(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 275 Agrif_Parent(nit000)+1),' time step' 276 Write(*,*) 'child grid value : ', & 277 (nitend-nit000+1),' time step' 278 Write(*,*) 'value on child grid should be : ', & 279 Agrif_IRhot() * (Agrif_Parent(nitend)- & 280 Agrif_Parent(nit000)+1) 281 stop 282 Endif 283 ! 284 ! 285 IF ( ln_zps ) THEN 286 ! 287 ! check parameters for partial steps 288 ! 289 If( Agrif_Parent(e3zps_min) .ne. e3zps_min ) then 290 Write(*,*) 'incompatible e3zps_min between grids' 291 Write(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 292 Write(*,*) 'child grid :',e3zps_min 293 Write(*,*) 'those values should be identical' 294 stop 295 Endif 296 ! 297 If( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) then 298 Write(*,*) 'incompatible e3zps_rat between grids' 299 Write(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 300 Write(*,*) 'child grid :',e3zps_rat 301 Write(*,*) 'those values should be identical' 302 stop 303 Endif 304 ENDIF 305 ! 245 246 IF( check_namelist ) THEN 247 248 ! Check time steps 249 IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 250 WRITE(*,*) 'incompatible time step between grids' 251 WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 252 WRITE(*,*) 'child grid value : ',nint(rdt) 253 WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 254 STOP 255 ENDIF 256 257 ! Check run length 258 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 259 Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 260 WRITE(*,*) 'incompatible run length between grids' 261 WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 262 Agrif_Parent(nit000)+1),' time step' 263 WRITE(*,*) 'child grid value : ', & 264 (nitend-nit000+1),' time step' 265 WRITE(*,*) 'value on child grid should be : ', & 266 Agrif_IRhot() * (Agrif_Parent(nitend)- & 267 Agrif_Parent(nit000)+1) 268 STOP 269 ENDIF 270 271 ! Check coordinates 272 IF( ln_zps ) THEN 273 ! check parameters for partial steps 274 IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 275 WRITE(*,*) 'incompatible e3zps_min between grids' 276 WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 277 WRITE(*,*) 'child grid :',e3zps_min 278 WRITE(*,*) 'those values should be identical' 279 STOP 280 ENDIF 281 IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN 282 WRITE(*,*) 'incompatible e3zps_rat between grids' 283 WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 284 WRITE(*,*) 'child grid :',e3zps_rat 285 WRITE(*,*) 'those values should be identical' 286 STOP 287 ENDIF 288 ENDIF 289 306 290 ENDIF 307 ! 308 ! 309 310 Call Agrif_Update_tra(0) 311 Call Agrif_Update_dyn(0) 291 292 CALL Agrif_Update_tra(0) 293 CALL Agrif_Update_dyn(0) 294 295 nbcline = 0 296 297 END SUBROUTINE Agrif_InitValues 298 ! 299 300 SUBROUTINE Agrif_detect(g,sizex) 301 !!------------------------------------------ 302 !! *** ROUTINE Agrif_detect *** 303 !!------------------------------------------ 304 USE Agrif_Types 305 306 INTEGER, DIMENSION(2) :: sizex 307 INTEGER, DIMENSION(sizex(1),sizex(2)) :: g 308 309 Return 310 311 End SUBROUTINE Agrif_detect 312 313 #if defined key_mpp_mpi 314 315 SUBROUTINE Agrif_InvLoc(indloc,nprocloc,i,indglob) 316 !!------------------------------------------ 317 !! *** ROUTINE Agrif_detect *** 318 !!------------------------------------------ 319 USE dom_oce 312 320 313 nbcline = 0 314 315 Return 316 End Subroutine Agrif_InitValues 317 ! 318 SUBROUTINE Agrif_detect(g,sizex) 319 ! 320 ! Modules used: 321 ! 322 Use Agrif_Types 323 ! 324 ! 325 ! Declarations: 326 ! 327 ! 328 ! Variables 329 ! 330 Integer, Dimension(2) :: sizex 331 Integer, Dimension(sizex(1),sizex(2)) :: g 332 ! 333 ! Begin 334 ! 335 ! 336 337 ! 338 Return 339 End Subroutine Agrif_detect 340 341 #if defined key_mpp_mpi 342 ! 343 ! ************************************************************************** 344 !!! Subroutine Agrif_InvLoc 345 ! ************************************************************************** 346 ! 347 Subroutine Agrif_InvLoc(indloc,nprocloc,i,indglob) 348 ! 349 ! Description: 350 ! 351 USE dom_oce 352 353 ! Declarations: 354 ! 355 !! Implicit none 356 ! 357 Integer :: indglob,indloc,nprocloc,i 358 ! 359 ! 321 IMPLICIT NONE 322 323 INTEGER :: indglob,indloc,nprocloc,i 324 360 325 SELECT CASE(i) 361 362 326 CASE(1) 363 indglob = indloc + nimppt(nprocloc+1) - 1 364 327 indglob = indloc + nimppt(nprocloc+1) - 1 365 328 CASE(2) 366 indglob = indloc + njmppt(nprocloc+1) - 1 367 329 indglob = indloc + njmppt(nprocloc+1) - 1 368 330 CASE(3) 369 indglob = indloc 370 331 indglob = indloc 371 332 CASE(4) 372 indglob = indloc 373 333 indglob = indloc 374 334 END SELECT 375 ! 376 ! 377 End Subroutine Agrif_InvLoc 378 #endif 379 380 335 336 END SUBROUTINE Agrif_InvLoc 337 338 #endif 339 381 340 #else 382 subroutine Subcalledbyagrif 383 write(*,*) 'Impossible to bet here' 384 end subroutine Subcalledbyagrif 385 #endif 341 SUBROUTINE Subcalledbyagrif 342 !!------------------------------------------ 343 !! *** ROUTINE Subcalledbyagrif *** 344 !!------------------------------------------ 345 WRITE(*,*) 'Impossible to be here' 346 END SUBROUTINE Subcalledbyagrif 347 #endif
Note: See TracChangeset
for help on using the changeset viewer.
