Changeset 5951 for branches/2014/dev_r4650_UKMO14.4_OBS_GENERAL_VINTERP/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
- Timestamp:
- 2015-11-30T12:48:01+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO14.4_OBS_GENERAL_VINTERP/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r5950 r5951 1 #define TWO_WAY 2 1 #define TWO_WAY /* TWO WAY NESTING */ 2 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 3 3 4 MODULE agrif_opa_update 4 5 #if defined key_agrif && ! defined key_offline … … 10 11 USE lib_mpp 11 12 USE wrk_nemo 12 USE dynspg_oce13 USE zdf_oce ! vertical physics: ocean variables 13 14 14 15 IMPLICIT NONE 15 16 PRIVATE 16 17 17 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 18 19 INTEGER, PUBLIC :: nbcline = 020 18 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 19 # if defined key_zdftke 20 PUBLIC Agrif_Update_Tke 21 # endif 21 22 !!---------------------------------------------------------------------- 22 !! NEMO/NST 3. 3, NEMO Consortium (2010)23 !! NEMO/NST 3.6 , NEMO Consortium (2010) 23 24 !! $Id$ 24 25 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 27 28 CONTAINS 28 29 29 SUBROUTINE Agrif_Update_Tra( kt)30 RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 30 31 !!--------------------------------------------- 31 32 !! *** ROUTINE Agrif_Update_Tra *** 32 33 !!--------------------------------------------- 33 !! 34 INTEGER, INTENT(in) :: kt 35 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 36 37 38 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 39 #if defined TWO_WAY 40 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab ) 34 ! 35 IF (Agrif_Root()) RETURN 36 ! 37 #if defined TWO_WAY 38 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers from grid Number',Agrif_Fixed(), 'nbcline', nbcline 41 39 42 40 Agrif_UseSpecialValueInUpdate = .TRUE. 43 41 Agrif_SpecialValueFineGrid = 0. 44 42 ! 45 43 IF (MOD(nbcline,nbclineupdate) == 0) THEN 46 CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 47 ELSE 48 CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 49 ENDIF 50 44 # if ! defined DECAL_FEEDBACK 45 CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 46 # else 47 CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 48 # endif 49 ELSE 50 # if ! defined DECAL_FEEDBACK 51 CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 52 # else 53 CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 54 # endif 55 ENDIF 56 ! 51 57 Agrif_UseSpecialValueInUpdate = .FALSE. 52 53 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 58 ! 59 IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 60 CALL Agrif_ChildGrid_To_ParentGrid() 61 CALL Agrif_Update_Tra() 62 CALL Agrif_ParentGrid_To_ChildGrid() 63 ENDIF 64 ! 54 65 #endif 55 66 ! 56 67 END SUBROUTINE Agrif_Update_Tra 57 68 58 SUBROUTINE Agrif_Update_Dyn( kt)69 RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 59 70 !!--------------------------------------------- 60 71 !! *** ROUTINE Agrif_Update_Dyn *** 61 72 !!--------------------------------------------- 62 !! 63 INTEGER, INTENT(in) :: kt 64 REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d 65 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 66 67 68 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 73 ! 74 IF (Agrif_Root()) RETURN 75 ! 69 76 #if defined TWO_WAY 70 CALL wrk_alloc( jpi, jpj, ztab2d ) 71 CALL wrk_alloc( jpi, jpj, jpk, ztab ) 72 77 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline 78 79 Agrif_UseSpecialValueInUpdate = .FALSE. 80 Agrif_SpecialValueFineGrid = 0. 81 ! 73 82 IF (mod(nbcline,nbclineupdate) == 0) THEN 74 CALL Agrif_Update_Variable(ztab,un_id,procname = updateU) 75 CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV) 76 ELSE 77 CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU) 78 CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV) 79 ENDIF 80 81 CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d) 82 CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 83 84 #if defined key_dynspg_ts 85 IF (ln_bt_fw) THEN 83 # if ! defined DECAL_FEEDBACK 84 CALL Agrif_Update_Variable(un_update_id,procname = updateU) 85 CALL Agrif_Update_Variable(vn_update_id,procname = updateV) 86 # else 87 CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) 88 CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) 89 # endif 90 ELSE 91 # if ! defined DECAL_FEEDBACK 92 CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) 93 CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV) 94 # else 95 CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) 96 CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 97 # endif 98 ENDIF 99 100 # if ! defined DECAL_FEEDBACK 101 CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 102 CALL Agrif_Update_Variable(e2v_id,procname = updateV2d) 103 # else 104 CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) 105 CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d) 106 # endif 107 108 IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 86 109 ! Update time integrated transports 87 110 IF (mod(nbcline,nbclineupdate) == 0) THEN 88 CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b) 89 CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b) 111 # if ! defined DECAL_FEEDBACK 112 CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 113 CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 114 # else 115 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 116 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 117 # endif 90 118 ELSE 91 CALL Agrif_Update_Variable(ztab2d,ub2b_id,locupdate=(/0,1/),procname = updateub2b) 92 CALL Agrif_Update_Variable(ztab2d,vb2b_id,locupdate=(/0,1/),procname = updatevb2b) 119 # if ! defined DECAL_FEEDBACK 120 CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b) 121 CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b) 122 # else 123 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b) 124 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 125 # endif 93 126 ENDIF 94 END IF 127 END IF 128 ! 129 nbcline = nbcline + 1 130 ! 131 Agrif_UseSpecialValueInUpdate = .TRUE. 132 Agrif_SpecialValueFineGrid = 0. 133 # if ! defined DECAL_FEEDBACK 134 CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 135 # else 136 CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 137 # endif 138 Agrif_UseSpecialValueInUpdate = .FALSE. 139 ! 95 140 #endif 96 97 nbcline = nbcline + 1 98 99 Agrif_UseSpecialValueInUpdate = .TRUE. 141 ! 142 ! Do recursive update: 143 IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 144 CALL Agrif_ChildGrid_To_ParentGrid() 145 CALL Agrif_Update_Dyn() 146 CALL Agrif_ParentGrid_To_ChildGrid() 147 ENDIF 148 ! 149 END SUBROUTINE Agrif_Update_Dyn 150 151 # if defined key_zdftke 152 SUBROUTINE Agrif_Update_Tke( kt ) 153 !!--------------------------------------------- 154 !! *** ROUTINE Agrif_Update_Tke *** 155 !!--------------------------------------------- 156 !! 157 INTEGER, INTENT(in) :: kt 158 ! 159 IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 160 # if defined TWO_WAY 161 162 Agrif_UseSpecialValueInUpdate = .TRUE. 100 163 Agrif_SpecialValueFineGrid = 0. 101 CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) 164 165 CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN ) 166 CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) 167 CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) 168 102 169 Agrif_UseSpecialValueInUpdate = .FALSE. 103 170 104 CALL wrk_dealloc( jpi, jpj, ztab2d ) 105 CALL wrk_dealloc( jpi, jpj, jpk, ztab ) 106 107 !Done in step 108 ! CALL Agrif_ChildGrid_To_ParentGrid() 109 ! CALL recompute_diags( kt ) 110 ! CALL Agrif_ParentGrid_To_ChildGrid() 111 112 #endif 113 114 END SUBROUTINE Agrif_Update_Dyn 115 116 SUBROUTINE recompute_diags( kt ) 117 !!--------------------------------------------- 118 !! *** ROUTINE recompute_diags *** 119 !!--------------------------------------------- 120 INTEGER, INTENT(in) :: kt 121 122 END SUBROUTINE recompute_diags 171 # endif 172 173 END SUBROUTINE Agrif_Update_Tke 174 # endif /* key_zdftke */ 123 175 124 176 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 127 179 !!--------------------------------------------- 128 180 # include "domzgr_substitute.h90" 129 130 181 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 131 182 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 132 LOGICAL, iNTENT(in) :: before133 183 LOGICAL, INTENT(in) :: before 184 !! 134 185 INTEGER :: ji,jj,jk,jn 135 186 !!--------------------------------------------- 187 ! 136 188 IF (before) THEN 137 189 DO jn = n1,n2 … … 146 198 ELSE 147 199 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 148 ! Add asselin part200 ! Add asselin part 149 201 DO jn = n1,n2 150 202 DO jk=k1,k2 … … 153 205 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 154 206 tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 155 & + atfp * ( tabres(ji,jj,jk,jn) &156 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)207 & + atfp * ( tabres(ji,jj,jk,jn) & 208 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 157 209 ENDIF 158 210 ENDDO … … 161 213 ENDDO 162 214 ENDIF 163 164 215 DO jn = n1,n2 165 216 DO jk=k1,k2 … … 174 225 END DO 175 226 ENDIF 176 227 ! 177 228 END SUBROUTINE updateTS 178 229 … … 182 233 !!--------------------------------------------- 183 234 # include "domzgr_substitute.h90" 184 235 !! 185 236 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 186 237 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 187 238 LOGICAL, INTENT(in) :: before 188 239 !! 189 240 INTEGER :: ji, jj, jk 190 241 REAL(wp) :: zrhoy 191 242 !!--------------------------------------------- 243 ! 192 244 IF (before) THEN 193 245 zrhoy = Agrif_Rhoy() … … 209 261 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 210 262 ub(ji,jj,jk) = ub(ji,jj,jk) & 211 & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)263 & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 212 264 ENDIF 213 265 ! … … 217 269 END DO 218 270 ENDIF 219 271 ! 220 272 END SUBROUTINE updateu 221 273 … … 225 277 !!--------------------------------------------- 226 278 # include "domzgr_substitute.h90" 227 279 !! 228 280 INTEGER :: i1,i2,j1,j2,k1,k2 229 281 INTEGER :: ji,jj,jk 230 282 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 231 283 LOGICAL :: before 232 284 !! 233 285 REAL(wp) :: zrhox 234 286 !!--------------------------------------------- 287 ! 235 288 IF (before) THEN 236 289 zrhox = Agrif_Rhox() … … 252 305 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 253 306 vb(ji,jj,jk) = vb(ji,jj,jk) & 254 & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)307 & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 255 308 ENDIF 256 309 ! … … 260 313 END DO 261 314 ENDIF 262 315 ! 263 316 END SUBROUTINE updatev 264 317 … … 268 321 !!--------------------------------------------- 269 322 # include "domzgr_substitute.h90" 270 323 !! 271 324 INTEGER, INTENT(in) :: i1, i2, j1, j2 272 325 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 273 326 LOGICAL, INTENT(in) :: before 274 327 !! 275 328 INTEGER :: ji, jj, jk 276 329 REAL(wp) :: zrhoy 277 330 REAL(wp) :: zcorr 278 331 !!--------------------------------------------- 332 ! 279 333 IF (before) THEN 280 334 zrhoy = Agrif_Rhoy() … … 303 357 ! 304 358 ! Update barotropic velocities: 305 #if defined key_dynspg_ts 306 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part307 zcorr = tabres(ji,jj) - un_b(ji,jj)308 ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)309 END IF310 #endif359 IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 360 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 361 zcorr = tabres(ji,jj) - un_b(ji,jj) 362 ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1) 363 END IF 364 ENDIF 311 365 un_b(ji,jj) = tabres(ji,jj) * umask(ji,jj,1) 312 366 ! … … 326 380 END DO 327 381 ENDIF 328 382 ! 329 383 END SUBROUTINE updateu2d 330 384 … … 333 387 !! *** ROUTINE updatev2d *** 334 388 !!--------------------------------------------- 335 336 389 INTEGER, INTENT(in) :: i1, i2, j1, j2 337 390 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 338 391 LOGICAL, INTENT(in) :: before 339 392 !! 340 393 INTEGER :: ji, jj, jk 341 394 REAL(wp) :: zrhox 342 395 REAL(wp) :: zcorr 343 396 !!--------------------------------------------- 397 ! 344 398 IF (before) THEN 345 399 zrhox = Agrif_Rhox() … … 368 422 ! 369 423 ! Update barotropic velocities: 370 #if defined key_dynspg_ts 371 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part372 zcorr = tabres(ji,jj) - vn_b(ji,jj)373 vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)374 END IF375 #endif424 IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 425 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 426 zcorr = tabres(ji,jj) - vn_b(ji,jj) 427 vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1) 428 END IF 429 ENDIF 376 430 vn_b(ji,jj) = tabres(ji,jj) * vmask(ji,jj,1) 377 431 ! … … 391 445 END DO 392 446 ENDIF 393 447 ! 394 448 END SUBROUTINE updatev2d 395 449 450 396 451 SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 397 452 !!--------------------------------------------- 398 453 !! *** ROUTINE updateSSH *** 399 454 !!--------------------------------------------- 400 # include "domzgr_substitute.h90"401 402 455 INTEGER, INTENT(in) :: i1, i2, j1, j2 403 456 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 404 457 LOGICAL, INTENT(in) :: before 405 458 !! 406 459 INTEGER :: ji, jj 407 460 !!--------------------------------------------- 461 ! 408 462 IF (before) THEN 409 463 DO jj=j1,j2 … … 413 467 END DO 414 468 ELSE 415 416 #if ! defined key_dynspg_ts 417 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 469 IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 470 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 471 DO jj=j1,j2 472 DO ji=i1,i2 473 sshb(ji,jj) = sshb(ji,jj) & 474 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 475 END DO 476 END DO 477 ENDIF 478 ENDIF 479 480 DO jj=j1,j2 481 DO ji=i1,i2 482 sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1) 483 END DO 484 END DO 485 ENDIF 486 ! 487 END SUBROUTINE updateSSH 488 489 SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 490 !!--------------------------------------------- 491 !! *** ROUTINE updateub2b *** 492 !!--------------------------------------------- 493 INTEGER, INTENT(in) :: i1, i2, j1, j2 494 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 495 LOGICAL, INTENT(in) :: before 496 !! 497 INTEGER :: ji, jj 498 REAL(wp) :: zrhoy 499 !!--------------------------------------------- 500 ! 501 IF (before) THEN 502 zrhoy = Agrif_Rhoy() 503 DO jj=j1,j2 504 DO ji=i1,i2 505 tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj) 506 END DO 507 END DO 508 tabres = zrhoy * tabres 509 ELSE 510 DO jj=j1,j2 511 DO ji=i1,i2 512 ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj) 513 END DO 514 END DO 515 ENDIF 516 ! 517 END SUBROUTINE updateub2b 518 519 SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 520 !!--------------------------------------------- 521 !! *** ROUTINE updatevb2b *** 522 !!--------------------------------------------- 523 INTEGER, INTENT(in) :: i1, i2, j1, j2 524 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 525 LOGICAL, INTENT(in) :: before 526 !! 527 INTEGER :: ji, jj 528 REAL(wp) :: zrhox 529 !!--------------------------------------------- 530 ! 531 IF (before) THEN 532 zrhox = Agrif_Rhox() 533 DO jj=j1,j2 534 DO ji=i1,i2 535 tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 536 END DO 537 END DO 538 tabres = zrhox * tabres 539 ELSE 540 DO jj=j1,j2 541 DO ji=i1,i2 542 vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj) 543 END DO 544 END DO 545 ENDIF 546 ! 547 END SUBROUTINE updatevb2b 548 549 550 SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 551 ! currently not used 552 !!--------------------------------------------- 553 !! *** ROUTINE updateT *** 554 !!--------------------------------------------- 555 # include "domzgr_substitute.h90" 556 557 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 558 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 559 LOGICAL, iNTENT(in) :: before 560 561 INTEGER :: ji,jj,jk 562 REAL(wp) :: ztemp 563 564 IF (before) THEN 565 DO jk=k1,k2 418 566 DO jj=j1,j2 419 567 DO ji=i1,i2 420 sshb(ji,jj) = sshb(ji,jj) & 421 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 422 END DO 423 END DO 424 ENDIF 425 #endif 426 DO jj=j1,j2 427 DO ji=i1,i2 428 sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1) 429 END DO 430 END DO 431 ENDIF 432 433 END SUBROUTINE updateSSH 434 435 SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 436 !!--------------------------------------------- 437 !! *** ROUTINE updateub2b *** 438 !!--------------------------------------------- 439 440 INTEGER, INTENT(in) :: i1, i2, j1, j2 441 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 442 LOGICAL, INTENT(in) :: before 443 444 INTEGER :: ji, jj 445 REAL(wp) :: zrhoy 446 447 IF (before) THEN 448 zrhoy = Agrif_Rhoy() 449 DO jj=j1,j2 450 DO ji=i1,i2 451 tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj) 452 END DO 453 END DO 454 tabres = zrhoy * tabres 455 ELSE 456 DO jj=j1,j2 457 DO ji=i1,i2 458 ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj) 459 END DO 460 END DO 461 ENDIF 462 463 END SUBROUTINE updateub2b 464 465 SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 466 !!--------------------------------------------- 467 !! *** ROUTINE updatevb2b *** 468 !!--------------------------------------------- 469 470 INTEGER, INTENT(in) :: i1, i2, j1, j2 471 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 472 LOGICAL, INTENT(in) :: before 473 474 INTEGER :: ji, jj 475 REAL(wp) :: zrhox 476 477 IF (before) THEN 478 zrhox = Agrif_Rhox() 479 DO jj=j1,j2 480 DO ji=i1,i2 481 tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 482 END DO 483 END DO 484 tabres = zrhox * tabres 485 ELSE 486 DO jj=j1,j2 487 DO ji=i1,i2 488 vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj) 489 END DO 490 END DO 491 ENDIF 492 493 END SUBROUTINE updatevb2b 568 tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 569 tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 570 tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 571 END DO 572 END DO 573 END DO 574 tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 575 tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 576 tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 577 ELSE 578 DO jk=k1,k2 579 DO jj=j1,j2 580 DO ji=i1,i2 581 IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN 582 print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 583 print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 584 print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 585 ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 586 print *,'CORR = ',ztemp-1. 587 print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 588 tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 589 e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 590 e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 591 END IF 592 END DO 593 END DO 594 END DO 595 ENDIF 596 ! 597 END SUBROUTINE update_scales 598 599 # if defined key_zdftke 600 SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 601 !!--------------------------------------------- 602 !! *** ROUTINE updateen *** 603 !!--------------------------------------------- 604 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 605 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 606 LOGICAL, INTENT(in) :: before 607 !!--------------------------------------------- 608 ! 609 IF (before) THEN 610 ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 611 ELSE 612 en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 613 ENDIF 614 ! 615 END SUBROUTINE updateEN 616 617 618 SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 619 !!--------------------------------------------- 620 !! *** ROUTINE updateavt *** 621 !!--------------------------------------------- 622 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 623 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 624 LOGICAL, INTENT(in) :: before 625 !!--------------------------------------------- 626 ! 627 IF (before) THEN 628 ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 629 ELSE 630 avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 631 ENDIF 632 ! 633 END SUBROUTINE updateAVT 634 635 636 SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 637 !!--------------------------------------------- 638 !! *** ROUTINE updateavm *** 639 !!--------------------------------------------- 640 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 641 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 642 LOGICAL, INTENT(in) :: before 643 !!--------------------------------------------- 644 ! 645 IF (before) THEN 646 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 647 ELSE 648 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 649 ENDIF 650 ! 651 END SUBROUTINE updateAVM 652 653 # endif /* key_zdftke */ 494 654 495 655 #else
Note: See TracChangeset
for help on using the changeset viewer.