- Timestamp:
- 2017-04-23T09:30:41+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r7646 r7953 3 3 4 4 MODULE agrif_opa_update 5 !!====================================================================== 6 !! *** MODULE agrif_opa_interp *** 7 !! AGRIF: interpolation package 8 !!====================================================================== 9 !! History : 2.0 ! 2002-06 (XXX) Original cade 10 !! - ! 2005-11 (XXX) 11 !! 3.2 ! 2009-04 (R. Benshila) 12 !! 3.6 ! 2014-09 (R. Benshila) 13 !!---------------------------------------------------------------------- 5 14 #if defined key_agrif 15 !!---------------------------------------------------------------------- 16 !! 'key_agrif' AGRIF zoom 17 !!---------------------------------------------------------------------- 6 18 USE par_oce 7 19 USE oce 8 20 USE dom_oce 21 USE zdf_oce ! vertical physics: ocean variables 9 22 USE agrif_oce 10 USE in_out_manager ! I/O manager 23 ! 24 USE in_out_manager ! I/O manager 11 25 USE lib_mpp 12 26 USE wrk_nemo 13 USE zdf_oce ! vertical physics: ocean variables14 27 15 28 IMPLICIT NONE 16 29 PRIVATE 17 30 18 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 19 # if defined key_zdftke 20 PUBLIC Agrif_Update_Tke 21 # endif 31 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn, Update_Scales 32 PUBLIC Agrif_Update_Tke 33 22 34 !!---------------------------------------------------------------------- 23 !! NEMO/NST 3.6 , NEMO Consortium (2010)35 !! NEMO/NST 4.0 , NEMO Consortium (2017) 24 36 !! $Id$ 25 37 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 28 40 29 41 RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 30 !!--------------------------------------------- 31 !! *** ROUTINE Agrif_Update_Tra ***32 !!--------------------------------------------- 42 !!---------------------------------------------------------------------- 43 !! *** ROUTINE Agrif_Update_Tra *** 44 !!---------------------------------------------------------------------- 33 45 ! 34 46 IF (Agrif_Root()) RETURN … … 38 50 39 51 Agrif_UseSpecialValueInUpdate = .TRUE. 40 Agrif_SpecialValueFineGrid = 0.52 Agrif_SpecialValueFineGrid = 0._wp 41 53 ! 42 54 IF (MOD(nbcline,nbclineupdate) == 0) THEN … … 68 80 69 81 RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 70 !!--------------------------------------------- 71 !! *** ROUTINE Agrif_Update_Dyn ***72 !!--------------------------------------------- 82 !!---------------------------------------------------------------------- 83 !! *** ROUTINE Agrif_Update_Dyn *** 84 !!---------------------------------------------------------------------- 73 85 ! 74 86 IF (Agrif_Root()) RETURN … … 106 118 # endif 107 119 108 IF ( ln_dynspg_ts .AND.ln_bt_fw ) THEN120 IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN 109 121 ! Update time integrated transports 110 122 IF (mod(nbcline,nbclineupdate) == 0) THEN … … 149 161 END SUBROUTINE Agrif_Update_Dyn 150 162 151 # if defined key_zdftke 163 !!gm Missing GLS case !!!!! 152 164 153 165 SUBROUTINE Agrif_Update_Tke( kt ) 154 !!--------------------------------------------- 155 !! *** ROUTINE Agrif_Update_Tke *** 156 !!--------------------------------------------- 157 !! 166 !!---------------------------------------------------------------------- 167 !! *** ROUTINE Agrif_Update_Tke *** 168 !!---------------------------------------------------------------------- 158 169 INTEGER, INTENT(in) :: kt 159 ! 160 IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 170 !!---------------------------------------------------------------------- 171 ! 172 !!gm test on kt/=0 ???? why not nit000-1 ? doesn't seem logic 173 IF( ( Agrif_NbStepint() /= 0 ) .AND. kt /= 0 ) RETURN 161 174 # if defined TWO_WAY 162 175 ! 163 176 Agrif_UseSpecialValueInUpdate = .TRUE. 164 Agrif_SpecialValueFineGrid = 0.165 166 CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN )167 CALL Agrif_Update_Variable( avt_id, locupdate=(/0,0/), procname=updateAVT )168 CALL Agrif_Update_Variable( avm_id, locupdate=(/0,0/), procname=updateAVM )169 177 Agrif_SpecialValueFineGrid = 0._wp 178 ! 179 CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN ) 180 CALL Agrif_Update_Variable( avt_id, locupdate=(/0,0/), procname=updateAVT ) 181 CALL Agrif_Update_Variable( avm_id, locupdate=(/0,0/), procname=updateAVM ) 182 ! 170 183 Agrif_UseSpecialValueInUpdate = .FALSE. 171 184 ! 172 185 # endif 173 186 ! 174 187 END SUBROUTINE Agrif_Update_Tke 175 188 176 # endif /* key_zdftke */177 189 178 190 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 179 !!--------------------------------------------- 191 !!---------------------------------------------------------------------- 180 192 !! *** ROUTINE updateT *** 181 !!--------------------------------------------- 182 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2183 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres184 LOGICAL , INTENT(in) ::before185 ! !186 INTEGER :: ji, jj,jk,jn187 !!--------------------------------------------- 188 ! 189 IF (before) THEN190 DO jn = n1, n2191 DO jk =k1,k2192 DO jj =j1,j2193 DO ji =i1,i2193 !!---------------------------------------------------------------------- 194 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 195 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 196 LOGICAL , INTENT(in ) :: before 197 ! 198 INTEGER :: ji, jj, jk, jn 199 !!---------------------------------------------------------------------- 200 ! 201 IF( before ) THEN 202 DO jn = n1, n2 203 DO jk = k1, k2 204 DO jj = j1, j2 205 DO ji = i1, i2 194 206 tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) 195 207 END DO … … 209 221 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 210 222 ENDIF 211 END DO212 END DO213 END DO214 END DO223 END DO 224 END DO 225 END DO 226 END DO 215 227 ENDIF 216 228 DO jn = n1,n2 … … 238 250 LOGICAL , INTENT(in ) :: before 239 251 ! 240 INTEGER 241 REAL(wp) 252 INTEGER :: ji, jj, jk 253 REAL(wp):: zrhoy 242 254 !!--------------------------------------------- 243 255 ! … … 268 280 269 281 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before ) 270 !!--------------------------------------------- 271 !! *** ROUTINE updatev *** 272 !!--------------------------------------------- 273 INTEGER :: i1,i2,j1,j2,k1,k2 274 INTEGER :: ji,jj,jk 275 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 276 LOGICAL :: before 282 !!---------------------------------------------------------------------- 283 !! *** ROUTINE updatev *** 284 !!---------------------------------------------------------------------- 285 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 286 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 287 LOGICAL , INTENT(in ) :: before 277 288 !! 278 REAL(wp) :: zrhox 279 !!--------------------------------------------- 280 ! 281 IF (before) THEN 289 INTEGER :: ji, jj, jk 290 REAL(wp) :: zrhox 291 !!---------------------------------------------------------------------- 292 ! 293 IF( before ) THEN 282 294 zrhox = Agrif_Rhox() 283 295 DO jk=k1,k2 … … 309 321 310 322 SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before ) 323 !!---------------------------------------------------------------------- 324 !! *** ROUTINE updateu2d *** 325 !!---------------------------------------------------------------------- 326 INTEGER , INTENT(in ) :: i1, i2, j1, j2 327 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 328 LOGICAL , INTENT(in ) :: before 329 !! 330 INTEGER :: ji, jj, jk 331 REAL(wp):: zrhoy, zcorr 311 332 !!--------------------------------------------- 312 !! *** ROUTINE updateu2d *** 313 !!--------------------------------------------- 314 INTEGER, INTENT(in) :: i1, i2, j1, j2 315 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 316 LOGICAL, INTENT(in) :: before 317 !! 318 INTEGER :: ji, jj, jk 319 REAL(wp) :: zrhoy 320 REAL(wp) :: zcorr 321 !!--------------------------------------------- 322 ! 323 IF (before) THEN 333 ! 334 IF( before ) THEN 324 335 zrhoy = Agrif_Rhoy() 325 336 DO jj=j1,j2 … … 374 385 375 386 SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before ) 376 !!--------------------------------------------- 377 !! *** ROUTINE updatev2d ***378 !!--------------------------------------------- 379 INTEGER , INTENT(in) ::i1, i2, j1, j2380 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres381 LOGICAL , INTENT(in) ::before382 ! !387 !!---------------------------------------------------------------------- 388 !! *** ROUTINE updatev2d *** 389 !!---------------------------------------------------------------------- 390 INTEGER , INTENT(in ) :: i1, i2, j1, j2 391 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 392 LOGICAL , INTENT(in ) :: before 393 ! 383 394 INTEGER :: ji, jj, jk 384 REAL(wp) :: zrhox 385 REAL(wp) :: zcorr 386 !!--------------------------------------------- 387 ! 388 IF (before) THEN 395 REAL(wp) :: zrhox, zcorr 396 !!---------------------------------------------------------------------- 397 ! 398 IF( before ) THEN 389 399 zrhox = Agrif_Rhox() 390 400 DO jj=j1,j2 … … 439 449 440 450 SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 441 !!--------------------------------------------- 442 !! *** ROUTINE updateSSH ***443 !!--------------------------------------------- 444 INTEGER , INTENT(in) ::i1, i2, j1, j2445 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres446 LOGICAL , INTENT(in) ::before451 !!---------------------------------------------------------------------- 452 !! *** ROUTINE updateSSH *** 453 !!---------------------------------------------------------------------- 454 INTEGER , INTENT(in ) :: i1, i2, j1, j2 455 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 456 LOGICAL , INTENT(in ) :: before 447 457 !! 448 458 INTEGER :: ji, jj 449 !!--------------------------------------------- 450 ! 451 IF (before) THEN459 !!---------------------------------------------------------------------- 460 ! 461 IF( before ) THEN 452 462 DO jj=j1,j2 453 463 DO ji=i1,i2 … … 478 488 479 489 SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 480 !!--------------------------------------------- 481 !! *** ROUTINE updateub2b ***482 !!--------------------------------------------- 483 INTEGER , INTENT(in) ::i1, i2, j1, j2484 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres485 LOGICAL , INTENT(in) ::before490 !!---------------------------------------------------------------------- 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 486 496 !! 487 INTEGER :: ji, jj488 REAL(wp) ::zrhoy489 !!--------------------------------------------- 497 INTEGER :: ji, jj 498 REAL(wp):: zrhoy 499 !!---------------------------------------------------------------------- 490 500 ! 491 501 IF (before) THEN … … 509 519 510 520 SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 511 !!--------------------------------------------- 512 !! *** ROUTINE updatevb2b ***513 !!--------------------------------------------- 514 INTEGER , INTENT(in) ::i1, i2, j1, j2515 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres516 LOGICAL , INTENT(in) ::before521 !!---------------------------------------------------------------------- 522 !! *** ROUTINE updatevb2b *** 523 !!---------------------------------------------------------------------- 524 INTEGER , INTENT(in ) :: i1, i2, j1, j2 525 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 526 LOGICAL , INTENT(in ) :: before 517 527 !! 518 INTEGER :: ji, jj519 REAL(wp) ::zrhox520 !!--------------------------------------------- 521 ! 522 IF (before) THEN528 INTEGER :: ji, jj 529 REAL(wp):: zrhox 530 !!---------------------------------------------------------------------- 531 ! 532 IF( before ) THEN 523 533 zrhox = Agrif_Rhox() 524 534 DO jj=j1,j2 … … 540 550 541 551 SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 542 ! currently not used 543 !!--------------------------------------------- 544 !! *** ROUTINE updateT *** 545 !!--------------------------------------------- 546 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 547 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 548 LOGICAL, iNTENT(in) :: before 549 ! 552 ! 553 ! ====>>>>>>>>>> currently not used 554 ! 555 !!---------------------------------------------------------------------- 556 !! *** ROUTINE updateT *** 557 !!---------------------------------------------------------------------- 558 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 559 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 560 LOGICAL , INTENT(in ) :: before 561 !! 550 562 INTEGER :: ji,jj,jk 551 563 REAL(wp) :: ztemp 552 !!--------------------------------------------- 564 !!---------------------------------------------------------------------- 553 565 554 566 IF (before) THEN … … 587 599 END SUBROUTINE update_scales 588 600 589 # if defined key_zdftke590 601 591 602 SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 592 !!--------------------------------------------- 593 !! *** ROUTINE updateen ***594 !!--------------------------------------------- 595 INTEGER , INTENT(in) ::i1, i2, j1, j2, k1, k2596 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab597 LOGICAL , INTENT(in) ::before598 !!--------------------------------------------- 599 ! 600 IF (before) THEN603 !!---------------------------------------------------------------------- 604 !! *** ROUTINE updateen *** 605 !!---------------------------------------------------------------------- 606 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 607 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 608 LOGICAL , INTENT(in ) :: before 609 !!---------------------------------------------------------------------- 610 ! 611 IF( before ) THEN 601 612 ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 602 613 ELSE … … 608 619 609 620 SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 610 !!--------------------------------------------- 611 !! *** ROUTINE updateavt *** 612 !!--------------------------------------------- 613 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 614 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 615 LOGICAL, INTENT(in) :: before 616 !!--------------------------------------------- 617 ! 618 IF (before) THEN 619 ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 620 ELSE 621 avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 621 !!---------------------------------------------------------------------- 622 !! *** ROUTINE updateavt *** 623 !!---------------------------------------------------------------------- 624 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 625 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 626 LOGICAL , INTENT(in ) :: before 627 !!---------------------------------------------------------------------- 628 ! 629 IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 630 ELSE ; avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 622 631 ENDIF 623 632 ! … … 628 637 !!--------------------------------------------- 629 638 !! *** ROUTINE updateavm *** 630 !!--------------------------------------------- 631 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 632 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 633 LOGICAL, INTENT(in) :: before 634 !!--------------------------------------------- 635 ! 636 IF (before) THEN 637 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 638 ELSE 639 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 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 ; ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 646 ELSE ; avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 640 647 ENDIF 641 648 ! 642 649 END SUBROUTINE updateAVM 643 650 644 # endif /* key_zdftke */645 646 651 #else 652 !!---------------------------------------------------------------------- 653 !! Empty module no AGRIF zoom 654 !!---------------------------------------------------------------------- 647 655 CONTAINS 648 656 SUBROUTINE agrif_opa_update_empty 649 !!---------------------------------------------650 !! *** ROUTINE agrif_opa_update_empty ***651 !!---------------------------------------------652 657 WRITE(*,*) 'agrif_opa_update : You should not have seen this print! error?' 653 658 END SUBROUTINE agrif_opa_update_empty 654 659 #endif 660 661 !!====================================================================== 655 662 END MODULE agrif_opa_update 656 663
Note: See TracChangeset
for help on using the changeset viewer.
