- Timestamp:
- 2013-11-18T12:57:11+01:00 (11 years ago)
- Location:
- branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 15 edited
-
BDY/bdydta.F90 (modified) (1 diff)
-
DOM/dtatsd.F90 (modified) (1 diff)
-
LBC/lbcnfd.F90 (modified) (4 diffs)
-
LBC/lib_mpp.F90 (modified) (10 diffs)
-
SBC/cyclone.F90 (modified) (1 diff)
-
SBC/fldread.F90 (modified) (11 diffs)
-
SBC/sbc_oce.F90 (modified) (2 diffs)
-
SBC/sbcapr.F90 (modified) (1 diff)
-
SBC/sbcblk_core.F90 (modified) (1 diff)
-
SBC/sbcice_cice.F90 (modified) (2 diffs)
-
SBC/sbcmod.F90 (modified) (2 diffs)
-
SBC/sbcwave.F90 (modified) (1 diff)
-
TRA/tranxt.F90 (modified) (3 diffs)
-
nemogcm.F90 (modified) (3 diffs)
-
step.F90 (modified) (3 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90
r4148 r4230 446 446 DO ib_bdy = 1, nb_bdy 447 447 IF( nn_dta(ib_bdy) .eq. 1 ) THEN 448 449 448 READ ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) 450 449 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_dta in reference namelist', lwp ) -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/DOM/dtatsd.F90
r4147 r4230 73 73 cn_dir = './' ! directory in which the model is executed 74 74 ! ! sn_... default values (NB: frequency positive => hours, negative => months) 75 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! 76 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! 77 sn_tem = FLD_N( 'temperature', -1. , 'votemper', .false. , .true. , 'monthly' , '' , '' ) 78 sn_sal = FLD_N( 'salinity' , -1. , 'vosaline', .false. , .true. , 'monthly' , '' , '' ) 75 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! land/sea mask ! 76 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! filename ! 77 sn_tem = FLD_N( 'temperature', -1. , 'votemper', .false. , .true. , 'monthly' , '' , & 78 & '' , '' ) 79 sn_sal = FLD_N( 'salinity' , -1. , 'vosaline', .false. , .true. , 'monthly' , '' , & 80 & '' , '' ) 79 81 80 82 REWIND( numnam_ref ) ! Namelist namtsd in reference namelist : -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r4152 r4230 5 5 !!====================================================================== 6 6 !! History : 3.2 ! 2009-03 (R. Benshila) Original code 7 !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization 7 8 !!---------------------------------------------------------------------- 8 9 … … 11 12 !! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd) 12 13 !! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd) 14 !! mpp_lbc_nfd_3d : North fold treatment for a 3D arrays optimized for MPP 15 !! mpp_lbc_nfd_2d : North fold treatment for a 2D arrays optimized for MPP 13 16 !!---------------------------------------------------------------------- 14 17 USE dom_oce ! ocean space and time domain … … 23 26 24 27 PUBLIC lbc_nfd ! north fold conditions 28 INTERFACE mpp_lbc_nfd 29 MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 30 END INTERFACE 31 32 PUBLIC mpp_lbc_nfd ! north fold conditions in parallel case 33 34 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 35 INTEGER, PUBLIC :: nsndto 36 INTEGER, PUBLIC, DIMENSION (jpmaxngh) :: isendto ! processes to which communicate 37 38 25 39 26 40 !!---------------------------------------------------------------------- … … 361 375 END SUBROUTINE lbc_nfd_2d 362 376 363 !!====================================================================== 377 378 SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 379 !!---------------------------------------------------------------------- 380 !! *** routine mpp_lbc_nfd_3d *** 381 !! 382 !! ** Purpose : 3D lateral boundary condition : North fold treatment 383 !! without processor exchanges. 384 !! 385 !! ** Method : 386 !! 387 !! ** Action : pt3d with updated values along the north fold 388 !!---------------------------------------------------------------------- 389 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 390 ! ! = T , U , V , F , W points 391 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 392 ! ! = -1. , the sign is changed if north fold boundary 393 ! ! = 1. , the sign is kept if north fold boundary 394 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3dl ! 3D array on which the boundary condition is applied 395 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pt3dr ! 3D array on which the boundary condition is applied 396 ! 397 INTEGER :: ji, jk 398 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 399 !!---------------------------------------------------------------------- 400 401 SELECT CASE ( jpni ) 402 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 403 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 404 END SELECT 405 ijpjm1 = ijpj-1 406 407 ! 408 SELECT CASE ( npolj ) 409 ! 410 CASE ( 3 , 4 ) ! * North fold T-point pivot 411 ! 412 SELECT CASE ( cd_type ) 413 CASE ( 'T' , 'W' ) ! T-, W-point 414 IF (narea .ne. (jpnij - jpni + 1)) THEN 415 startloop = 1 416 ELSE 417 startloop = 2 418 ENDIF 419 420 DO jk = 1, jpk 421 DO ji = startloop, nlci 422 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 423 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 424 END DO 425 END DO 426 427 IF(nimpp .ge. (jpiglo/2+1)) THEN 428 startloop = 1 429 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 430 startloop = jpiglo/2+1 - nimpp + 1 431 ELSE 432 startloop = nlci + 1 433 ENDIF 434 IF(startloop .le. nlci) THEN 435 DO jk = 1, jpk 436 DO ji = startloop, nlci 437 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 438 jia = ji + nimpp - 1 439 ijta = jpiglo - jia + 2 440 IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 441 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 442 ELSE 443 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 444 ENDIF 445 END DO 446 END DO 447 ENDIF 448 449 450 451 CASE ( 'U' ) ! U-point 452 IF (narea .ne. (jpnij)) THEN 453 endloop = nlci 454 ELSE 455 endloop = nlci - 1 456 ENDIF 457 DO jk = 1, jpk 458 DO ji = 1, endloop 459 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 460 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 461 END DO 462 END DO 463 464 IF (narea .ne. (jpnij)) THEN 465 endloop = nlci 466 ELSE 467 endloop = nlci - 1 468 ENDIF 469 IF(nimpp .ge. (jpiglo/2)) THEN 470 startloop = 1 471 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 472 startloop = jpiglo/2 - nimpp + 1 473 ELSE 474 startloop = endloop + 1 475 ENDIF 476 IF (startloop .le. endloop) THEN 477 DO jk = 1, jpk 478 DO ji = startloop, endloop 479 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 480 jia = ji + nimpp - 1 481 ijua = jpiglo - jia + 1 482 IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 483 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 484 ELSE 485 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 486 ENDIF 487 END DO 488 END DO 489 ENDIF 490 491 CASE ( 'V' ) ! V-point 492 IF (narea .ne. (jpnij - jpni + 1)) THEN 493 startloop = 1 494 ELSE 495 startloop = 2 496 ENDIF 497 DO jk = 1, jpk 498 DO ji = startloop, nlci 499 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 500 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 501 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 502 END DO 503 END DO 504 CASE ( 'F' ) ! F-point 505 IF (narea .ne. (jpnij)) THEN 506 endloop = nlci 507 ELSE 508 endloop = nlci - 1 509 ENDIF 510 DO jk = 1, jpk 511 DO ji = 1, endloop 512 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 513 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 514 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 515 END DO 516 END DO 517 END SELECT 518 ! 519 520 CASE ( 5 , 6 ) ! * North fold F-point pivot 521 ! 522 SELECT CASE ( cd_type ) 523 CASE ( 'T' , 'W' ) ! T-, W-point 524 DO jk = 1, jpk 525 DO ji = 1, nlci 526 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 527 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 528 END DO 529 END DO 530 531 CASE ( 'U' ) ! U-point 532 IF (narea .ne. (jpnij)) THEN 533 endloop = nlci 534 ELSE 535 endloop = nlci - 1 536 ENDIF 537 DO jk = 1, jpk 538 DO ji = 1, endloop 539 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 540 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 541 END DO 542 END DO 543 544 CASE ( 'V' ) ! V-point 545 DO jk = 1, jpk 546 DO ji = 1, nlci 547 ijt = jpiglo - ji- nimpp - nimppt(isendto(1)) + 3 548 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 549 END DO 550 END DO 551 552 IF(nimpp .ge. (jpiglo/2+1)) THEN 553 startloop = 1 554 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 555 startloop = jpiglo/2+1 - nimpp + 1 556 ELSE 557 startloop = nlci + 1 558 ENDIF 559 IF(startloop .le. nlci) THEN 560 DO jk = 1, jpk 561 DO ji = startloop, nlci 562 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 563 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 564 END DO 565 END DO 566 ENDIF 567 568 CASE ( 'F' ) ! F-point 569 IF (narea .ne. (jpnij)) THEN 570 endloop = nlci 571 ELSE 572 endloop = nlci - 1 573 ENDIF 574 DO jk = 1, jpk 575 DO ji = 1, endloop 576 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 577 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 578 END DO 579 END DO 580 581 IF (narea .ne. (jpnij)) THEN 582 endloop = nlci 583 ELSE 584 endloop = nlci - 1 585 ENDIF 586 IF(nimpp .ge. (jpiglo/2+1)) THEN 587 startloop = 1 588 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 589 startloop = jpiglo/2+1 - nimpp + 1 590 ELSE 591 startloop = endloop + 1 592 ENDIF 593 IF (startloop .le. endloop) THEN 594 DO jk = 1, jpk 595 DO ji = startloop, endloop 596 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 597 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 598 END DO 599 END DO 600 ENDIF 601 602 END SELECT 603 604 CASE DEFAULT ! * closed : the code probably never go through 605 ! 606 SELECT CASE ( cd_type) 607 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 608 pt3dl(:, 1 ,jk) = 0.e0 609 pt3dl(:,ijpj,jk) = 0.e0 610 CASE ( 'F' ) ! F-point 611 pt3dl(:,ijpj,jk) = 0.e0 612 END SELECT 613 ! 614 END SELECT ! npolj 615 ! 616 ! 617 END SUBROUTINE mpp_lbc_nfd_3d 618 619 620 SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 621 !!---------------------------------------------------------------------- 622 !! *** routine mpp_lbc_nfd_2d *** 623 !! 624 !! ** Purpose : 2D lateral boundary condition : North fold treatment 625 !! without processor exchanges. 626 !! 627 !! ** Method : 628 !! 629 !! ** Action : pt2d with updated values along the north fold 630 !!---------------------------------------------------------------------- 631 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 632 ! ! = T , U , V , F , W points 633 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 634 ! ! = -1. , the sign is changed if north fold boundary 635 ! ! = 1. , the sign is kept if north fold boundary 636 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2dl ! 2D array on which the boundary condition is applied 637 REAL(wp), DIMENSION(:,:), INTENT(in) :: pt2dr ! 2D array on which the boundary condition is applied 638 ! 639 INTEGER :: ji 640 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 641 !!---------------------------------------------------------------------- 642 643 SELECT CASE ( jpni ) 644 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 645 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 646 END SELECT 647 ! 648 ijpjm1 = ijpj-1 649 650 651 SELECT CASE ( npolj ) 652 ! 653 CASE ( 3, 4 ) ! * North fold T-point pivot 654 ! 655 SELECT CASE ( cd_type ) 656 ! 657 CASE ( 'T' , 'W' ) ! T- , W-points 658 IF (narea .ne. (jpnij - jpni + 1)) THEN 659 startloop = 1 660 ELSE 661 startloop = 2 662 ENDIF 663 DO ji = startloop, nlci 664 ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 665 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 666 END DO 667 668 IF(nimpp .ge. (jpiglo/2+1)) THEN 669 startloop = 1 670 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 671 startloop = jpiglo/2+1 - nimpp + 1 672 ELSE 673 startloop = nlci + 1 674 ENDIF 675 DO ji = startloop, nlci 676 ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 677 jia = ji + nimpp - 1 678 ijta = jpiglo - jia + 2 679 IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 680 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 681 ELSE 682 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 683 ENDIF 684 END DO 685 686 CASE ( 'U' ) ! U-point 687 IF (narea .ne. (jpnij)) THEN 688 endloop = nlci 689 ELSE 690 endloop = nlci - 1 691 ENDIF 692 DO ji = 1, endloop 693 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 694 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 695 END DO 696 697 IF (narea .ne. (jpnij)) THEN 698 endloop = nlci 699 ELSE 700 endloop = nlci - 1 701 ENDIF 702 IF(nimpp .ge. (jpiglo/2)) THEN 703 startloop = 1 704 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 705 startloop = jpiglo/2 - nimpp + 1 706 ELSE 707 startloop = endloop + 1 708 ENDIF 709 DO ji = startloop, endloop 710 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 711 jia = ji + nimpp - 1 712 ijua = jpiglo - jia + 1 713 IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 714 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 715 ELSE 716 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 717 ENDIF 718 END DO 719 720 CASE ( 'V' ) ! V-point 721 IF (narea .ne. (jpnij - jpni + 1)) THEN 722 startloop = 1 723 ELSE 724 startloop = 2 725 ENDIF 726 DO ji = startloop, nlci 727 ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 728 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 729 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 730 END DO 731 732 CASE ( 'F' ) ! F-point 733 IF (narea .ne. (jpnij)) THEN 734 endloop = nlci 735 ELSE 736 endloop = nlci - 1 737 ENDIF 738 DO ji = 1, endloop 739 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 740 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 741 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 742 END DO 743 744 CASE ( 'I' ) ! ice U-V point (I-point) 745 IF (narea .ne. (jpnij - jpni + 1)) THEN 746 startloop = 1 747 ELSE 748 startloop = 3 749 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 750 ENDIF 751 DO ji = startloop, nlci 752 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 753 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 754 END DO 755 756 CASE ( 'J' ) ! first ice U-V point 757 IF (narea .ne. (jpnij - jpni + 1)) THEN 758 startloop = 1 759 ELSE 760 startloop = 3 761 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 762 ENDIF 763 DO ji = startloop, nlci 764 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 765 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 766 END DO 767 768 CASE ( 'K' ) ! second ice U-V point 769 IF (narea .ne. (jpnij - jpni + 1)) THEN 770 startloop = 1 771 ELSE 772 startloop = 3 773 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 774 ENDIF 775 DO ji = startloop, nlci 776 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 777 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 778 END DO 779 780 END SELECT 781 ! 782 CASE ( 5, 6 ) ! * North fold F-point pivot 783 ! 784 SELECT CASE ( cd_type ) 785 CASE ( 'T' , 'W' ) ! T-, W-point 786 DO ji = 1, nlci 787 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 788 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 789 END DO 790 791 CASE ( 'U' ) ! U-point 792 IF (narea .ne. (jpnij)) THEN 793 endloop = nlci 794 ELSE 795 endloop = nlci - 1 796 ENDIF 797 DO ji = 1, endloop 798 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 799 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 800 END DO 801 802 CASE ( 'V' ) ! V-point 803 DO ji = 1, nlci 804 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 805 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 806 END DO 807 IF(nimpp .ge. (jpiglo/2+1)) THEN 808 startloop = 1 809 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 810 startloop = jpiglo/2+1 - nimpp + 1 811 ELSE 812 startloop = nlci + 1 813 ENDIF 814 DO ji = startloop, nlci 815 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 816 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 817 END DO 818 819 CASE ( 'F' ) ! F-point 820 IF (narea .ne. (jpnij)) THEN 821 endloop = nlci 822 ELSE 823 endloop = nlci - 1 824 ENDIF 825 DO ji = 1, endloop 826 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 827 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 828 END DO 829 830 IF (narea .ne. (jpnij)) THEN 831 endloop = nlci 832 ELSE 833 endloop = nlci - 1 834 ENDIF 835 IF(nimpp .ge. (jpiglo/2+1)) THEN 836 startloop = 1 837 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 838 startloop = jpiglo/2+1 - nimpp + 1 839 ELSE 840 startloop = endloop + 1 841 ENDIF 842 843 DO ji = startloop, endloop 844 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 845 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 846 END DO 847 848 CASE ( 'I' ) ! ice U-V point (I-point) 849 IF (narea .ne. (jpnij - jpni + 1)) THEN 850 startloop = 1 851 ELSE 852 startloop = 2 853 ENDIF 854 IF (narea .ne. jpnij) THEN 855 endloop = nlci 856 ELSE 857 endloop = nlci - 1 858 ENDIF 859 DO ji = startloop , endloop 860 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 861 pt2dl(ji,ijpj)= 0.5 * (pt2dr(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 862 END DO 863 864 CASE ( 'J' ) ! first ice U-V point 865 IF (narea .ne. (jpnij - jpni + 1)) THEN 866 startloop = 1 867 ELSE 868 startloop = 2 869 ENDIF 870 IF (narea .ne. jpnij) THEN 871 endloop = nlci 872 ELSE 873 endloop = nlci - 1 874 ENDIF 875 DO ji = startloop , endloop 876 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 877 pt2dl(ji,ijpj) = pt2dr(ji,ijpjm1) 878 END DO 879 880 CASE ( 'K' ) ! second ice U-V point 881 IF (narea .ne. (jpnij - jpni + 1)) THEN 882 startloop = 1 883 ELSE 884 startloop = 2 885 ENDIF 886 IF (narea .ne. jpnij) THEN 887 endloop = nlci 888 ELSE 889 endloop = nlci - 1 890 ENDIF 891 DO ji = startloop, endloop 892 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 893 pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 894 END DO 895 896 END SELECT 897 ! 898 CASE DEFAULT ! * closed : the code probably never go through 899 ! 900 SELECT CASE ( cd_type) 901 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 902 pt2dl(:, 1 ) = 0.e0 903 pt2dl(:,ijpj) = 0.e0 904 CASE ( 'F' ) ! F-point 905 pt2dl(:,ijpj) = 0.e0 906 CASE ( 'I' ) ! ice U-V point 907 pt2dl(:, 1 ) = 0.e0 908 pt2dl(:,ijpj) = 0.e0 909 CASE ( 'J' ) ! first ice U-V point 910 pt2dl(:, 1 ) = 0.e0 911 pt2dl(:,ijpj) = 0.e0 912 CASE ( 'K' ) ! second ice U-V point 913 pt2dl(:, 1 ) = 0.e0 914 pt2dl(:,ijpj) = 0.e0 915 END SELECT 916 ! 917 END SELECT 918 ! 919 END SUBROUTINE mpp_lbc_nfd_2d 920 364 921 END MODULE lbcnfd -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4162 r4230 22 22 !! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 23 23 !! the mppobc routine to optimize the BDY and OBC communications 24 !! 3.6 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 25 26 !!---------------------------------------------------------------------- 26 27 … … 151 152 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend 152 153 153 ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public 154 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 8 ! Assumed maximum number of active neighbours 155 INTEGER, PUBLIC, PARAMETER :: jptyps = 5 ! Number of different neighbour lists to be used for northfold exchanges 156 INTEGER, PUBLIC, DIMENSION (jpmaxngh,jptyps) :: isendto 157 INTEGER, PUBLIC, DIMENSION (jptyps) :: nsndto 158 LOGICAL, PUBLIC :: ln_nnogather = .FALSE. ! namelist control of northfold comms 154 LOGICAL, PUBLIC :: ln_nnogather ! namelist control of northfold comms 159 155 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. ! internal control of northfold comms 160 156 INTEGER, PUBLIC :: ityp … … 2592 2588 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2593 2589 ! ! = T , U , V , F or W gridpoints 2594 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2590 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2595 2591 !! ! = 1. , the sign is kept 2596 INTEGER :: ji, jj, jr 2592 INTEGER :: ji, jj, jr, jk 2597 2593 INTEGER :: ierr, itaille, ildi, ilei, iilb 2598 2594 INTEGER :: ijpj, ijpjm1, ij, iproc 2599 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! 2595 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2600 2596 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2601 2597 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather … … 2604 2600 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2605 2601 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 2606 2607 !!---------------------------------------------------------------------- 2608 ! 2609 ALLOCATE( ztab(jpiglo,4,jpk), znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) ) 2602 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 2603 2604 INTEGER :: istatus(mpi_status_size) 2605 INTEGER :: iflag 2606 !!---------------------------------------------------------------------- 2607 ! 2608 ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) ) 2609 ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) 2610 2610 2611 2611 ijpj = 4 2612 ityp = -12613 2612 ijpjm1 = 3 2614 ztab(:,:,:) = 0.e0 2615 ! 2616 DO jj = nlcj - ijpj +1, nlcj ! put in znorthloc the last 4 jlines of pt3d 2617 ij = jj - nlcj + ijpj 2618 znorthloc(:,ij,:) = pt3d(:,jj,:) 2613 ! 2614 DO jk = 1, jpk 2615 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d 2616 ij = jj - nlcj + ijpj 2617 znorthloc(:,ij,jk) = pt3d(:,jj,jk) 2618 END DO 2619 2619 END DO 2620 2620 ! 2621 2621 ! ! Build in procs of ncomm_north the znorthgloio 2622 2622 itaille = jpi * jpk * ijpj 2623 2624 2623 2625 IF ( l_north_nogather ) THEN 2624 2626 ! 2625 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2626 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2627 ! 2628 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2629 ij = jj - nlcj + ijpj 2630 DO ji = 1, nlci 2631 ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 2627 ztabr(:,:,:) = 0 2628 DO jk = 1, jpk 2629 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2630 ij = jj - nlcj + ijpj 2631 DO ji = 1, nlci 2632 ztabl(ji,ij,jk) = pt3d(ji,jj,jk) 2633 END DO 2634 END DO 2635 END DO 2636 2637 DO jr = 1,nsndto 2638 IF (isendto(jr) .ne. narea) CALL mppsend( 5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr) ) 2639 END DO 2640 DO jr = 1,nsndto 2641 iproc = isendto(jr) 2642 ildi = nldit (iproc) 2643 ilei = nleit (iproc) 2644 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2645 IF(isendto(jr) .ne. narea) THEN 2646 CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 2647 DO jk = 1, jpk 2648 DO jj = 1, ijpj 2649 DO ji = 1, ilei 2650 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) 2651 END DO 2652 END DO 2653 END DO 2654 ELSE 2655 DO jk = 1, jpk 2656 DO jj = 1, ijpj 2657 DO ji = 1, ilei 2658 ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 2659 END DO 2660 END DO 2661 END DO 2662 ENDIF 2663 END DO 2664 IF (l_isend) THEN 2665 DO jr = 1,nsndto 2666 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2632 2667 END DO 2633 END DO 2634 2635 ! 2636 ! Set the exchange type in order to access the correct list of active neighbours 2637 ! 2638 SELECT CASE ( cd_type ) 2639 CASE ( 'T' , 'W' ) 2640 ityp = 1 2641 CASE ( 'U' ) 2642 ityp = 2 2643 CASE ( 'V' ) 2644 ityp = 3 2645 CASE ( 'F' ) 2646 ityp = 4 2647 CASE ( 'I' ) 2648 ityp = 5 2649 CASE DEFAULT 2650 ityp = -1 ! Set a default value for unsupported types which 2651 ! will cause a fallback to the mpi_allgather method 2652 END SELECT 2653 IF ( ityp .gt. 0 ) THEN 2654 2655 DO jr = 1,nsndto(ityp) 2656 CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2657 END DO 2658 DO jr = 1,nsndto(ityp) 2659 CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp)) 2660 iproc = isendto(jr,ityp) + 1 2661 ildi = nldit (iproc) 2662 ilei = nleit (iproc) 2663 iilb = nimppt(iproc) 2664 DO jj = 1, ijpj 2665 DO ji = ildi, ilei 2666 ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:) 2667 END DO 2668 ENDIF 2669 CALL mpp_lbc_nfd( ztabl, ztabr_3d, cd_type, psgn ) ! North fold boundary condition 2670 ! 2671 DO jk = 1, jpk 2672 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2673 ij = jj - nlcj + ijpj 2674 DO ji= 1, nlci 2675 pt3d(ji,jj,jk) = ztabl(ji,ij,jk) 2668 2676 END DO 2669 2677 END DO 2670 IF (l_isend) THEN 2671 DO jr = 1,nsndto(ityp) 2672 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2673 END DO 2674 ENDIF 2675 2676 ENDIF 2677 2678 ENDIF 2679 2680 IF ( ityp .lt. 0 ) THEN 2678 END DO 2679 ! 2680 2681 ELSE 2681 2682 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 2682 2683 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2683 2684 ! 2685 ztab(:,:,:) = 0.e0 2684 2686 DO jr = 1, ndim_rank_north ! recover the global north array 2685 2687 iproc = nrank_north(jr) + 1 … … 2687 2689 ilei = nleit (iproc) 2688 2690 iilb = nimppt(iproc) 2689 DO jj = 1, ijpj 2690 DO ji = ildi, ilei 2691 ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 2691 DO jk = 1, jpk 2692 DO jj = 1, ijpj 2693 DO ji = ildi, ilei 2694 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 2695 END DO 2692 2696 END DO 2693 2697 END DO 2694 2698 END DO 2699 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2700 ! 2701 DO jk = 1, jpk 2702 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2703 ij = jj - nlcj + ijpj 2704 DO ji= 1, nlci 2705 pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk) 2706 END DO 2707 END DO 2708 END DO 2709 ! 2695 2710 ENDIF 2696 2711 ! … … 2704 2719 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2705 2720 ! 2706 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2707 ij = jj - nlcj + ijpj 2708 DO ji= 1, nlci 2709 pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:) 2710 END DO 2721 DO jk = 1, jpk 2722 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2723 ij = jj - nlcj + ijpj 2724 DO ji= 1, nlci 2725 pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk) 2726 END DO 2727 END DO 2711 2728 END DO 2712 2729 ! 2713 2730 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 2731 DEALLOCATE( ztabl, ztabr ) 2714 2732 ! 2715 2733 END SUBROUTINE mpp_lbc_north_3d … … 2730 2748 !! 2731 2749 !!---------------------------------------------------------------------- 2732 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the b.c. is applied2733 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt 3d grid-points2750 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the b.c. is applied 2751 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-points 2734 2752 ! ! = T , U , V , F or W gridpoints 2735 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2753 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2736 2754 !! ! = 1. , the sign is kept 2737 2755 INTEGER :: ji, jj, jr 2738 2756 INTEGER :: ierr, itaille, ildi, ilei, iilb 2739 2757 INTEGER :: ijpj, ijpjm1, ij, iproc 2740 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! 2758 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2741 2759 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2742 2760 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather … … 2745 2763 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2746 2764 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio 2765 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztabl, ztabr 2766 INTEGER :: istatus(mpi_status_size) 2767 INTEGER :: iflag 2747 2768 !!---------------------------------------------------------------------- 2748 2769 ! 2749 2770 ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) ) 2771 ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) ) 2750 2772 ! 2751 2773 ijpj = 4 2752 ityp = -12753 2774 ijpjm1 = 3 2754 ztab(:,:) = 0.e02755 2775 ! 2756 2776 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d … … 2763 2783 IF ( l_north_nogather ) THEN 2764 2784 ! 2765 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2785 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2766 2786 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2767 2787 ! 2788 ztabr(:,:) = 0 2768 2789 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2769 2790 ij = jj - nlcj + ijpj 2770 2791 DO ji = 1, nlci 2771 ztab (ji+nimpp-1,ij) = pt2d(ji,jj)2792 ztabl(ji,ij) = pt2d(ji,jj) 2772 2793 END DO 2773 2794 END DO 2774 2795 2775 ! 2776 ! Set the exchange type in order to access the correct list of active neighbours 2777 ! 2778 SELECT CASE ( cd_type ) 2779 CASE ( 'T' , 'W' ) 2780 ityp = 1 2781 CASE ( 'U' ) 2782 ityp = 2 2783 CASE ( 'V' ) 2784 ityp = 3 2785 CASE ( 'F' ) 2786 ityp = 4 2787 CASE ( 'I' ) 2788 ityp = 5 2789 CASE DEFAULT 2790 ityp = -1 ! Set a default value for unsupported types which 2791 ! will cause a fallback to the mpi_allgather method 2792 END SELECT 2793 2794 IF ( ityp .gt. 0 ) THEN 2795 2796 DO jr = 1,nsndto(ityp) 2797 CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2796 DO jr = 1,nsndto 2797 IF (isendto(jr) .ne. narea) CALL mppsend(5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr)) 2798 END DO 2799 DO jr = 1,nsndto 2800 iproc = isendto(jr) 2801 ildi = nldit (iproc) 2802 ilei = nleit (iproc) 2803 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2804 IF(isendto(jr) .ne. narea) THEN 2805 CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 2806 DO jj = 1, ijpj 2807 DO ji = 1, ilei 2808 ztabr(iilb+ji,jj) = zfoldwk(ji,jj) 2809 END DO 2810 END DO 2811 ELSE 2812 DO jj = 1, ijpj 2813 DO ji = 1, ilei 2814 ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 2815 END DO 2816 END DO 2817 ENDIF 2818 END DO 2819 IF (l_isend) THEN 2820 DO jr = 1,nsndto 2821 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2798 2822 END DO 2799 DO jr = 1,nsndto(ityp) 2800 CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp)) 2801 iproc = isendto(jr,ityp) + 1 2802 ildi = nldit (iproc) 2803 ilei = nleit (iproc) 2804 iilb = nimppt(iproc) 2805 DO jj = 1, ijpj 2806 DO ji = ildi, ilei 2807 ztab(ji+iilb-1,jj) = zfoldwk(ji,jj) 2808 END DO 2809 END DO 2823 ENDIF 2824 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition 2825 ! 2826 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2827 ij = jj - nlcj + ijpj 2828 DO ji = 1, nlci 2829 pt2d(ji,jj) = ztabl(ji,ij) 2810 2830 END DO 2811 IF (l_isend) THEN 2812 DO jr = 1,nsndto(ityp) 2813 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2814 END DO 2815 ENDIF 2816 2817 ENDIF 2818 2819 ENDIF 2820 2821 IF ( ityp .lt. 0 ) THEN 2831 END DO 2832 ! 2833 ELSE 2822 2834 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 2823 2835 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2824 2836 ! 2837 ztab(:,:) = 0.e0 2825 2838 DO jr = 1, ndim_rank_north ! recover the global north array 2826 2839 iproc = nrank_north(jr) + 1 … … 2834 2847 END DO 2835 2848 END DO 2836 ENDIF 2837 ! 2838 ! The ztab array has been either: 2839 ! a. Fully populated by the mpi_allgather operation or 2840 ! b. Had the active points for this domain and northern neighbours populated 2841 ! by peer to peer exchanges 2842 ! Either way the array may be folded by lbc_nfd and the result for the span of 2843 ! this domain will be identical. 2844 ! 2845 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2846 ! 2847 ! 2848 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2849 ij = jj - nlcj + ijpj 2850 DO ji = 1, nlci 2851 pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 2852 END DO 2853 END DO 2854 ! 2849 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition 2850 ! 2851 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2852 ij = jj - nlcj + ijpj 2853 DO ji = 1, nlci 2854 pt2d(ji,jj) = ztab(ji+nimpp-1,ij) 2855 END DO 2856 END DO 2857 ! 2858 ENDIF 2855 2859 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 2860 DEALLOCATE( ztabl, ztabr ) 2856 2861 ! 2857 2862 END SUBROUTINE mpp_lbc_north_2d -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/SBC/cyclone.F90
r4147 r4230 98 98 ! 99 99 ! (NB: frequency positive => hours, negative => months) 100 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! 101 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! 102 sn_tc = FLD_N( 'tc_track', 6 , 'tc' , .true. , .false. , 'yearly' , '' , '' )100 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! land/sea mask ! 101 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! filename ! 102 sn_tc = FLD_N( 'tc_track', 6 , 'tc' , .true. , .false. , 'yearly' , '' , '' , '' ) 103 103 ! 104 104 ! Namelist is read in namsbc_core -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r3851 r4230 7 7 !! ! 05-2008 (S. Alderson) Modified for Interpolation in memory 8 8 !! ! from input grid to model grid 9 !! ! 10-2013 (D. Delrosso, P. Oddo) implement suppression of 10 !! ! land point prior to interpolation 9 11 !!---------------------------------------------------------------------- 10 12 … … 22 24 USE wrk_nemo ! work arrays 23 25 USE ioipsl, ONLY : ymds2ju, ju2ymds ! for calendar 24 26 USE sbc_oce 27 25 28 IMPLICIT NONE 26 29 PRIVATE … … 40 43 ! ! a string starting with "U" or "V" for each component 41 44 ! ! chars 2 onwards identify which components go together 45 CHARACTER(len = 34) :: lname ! generic name of a NetCDF land/sea mask file to be used, blank if not 46 ! ! 0=sea 1=land 42 47 END TYPE FLD_N 43 48 … … 60 65 LOGICAL, DIMENSION(2) :: rotn ! flag to indicate whether before/after field has been rotated 61 66 INTEGER :: nreclast ! last record to be read in the current file 67 CHARACTER(len = 256) :: lsmname ! current name of the NetCDF mask file acting as a key 62 68 END TYPE FLD 63 69 … … 95 101 TYPE( WGT ), DIMENSION(tot_wgts) :: ref_wgts ! array of wgts 96 102 INTEGER :: nxt_wgt = 1 ! point to next available space in ref_wgts array 103 REAL(wp), PARAMETER :: undeff_lsm = -999.00_wp 97 104 98 105 !$AGRIF_END_DO_NOT_TREAT … … 591 598 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 592 599 CALL wgt_list( sdjf, iw ) 593 IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) ) 594 ELSE ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fnow(:,:,: ), sdjf%nrec_a(1) ) 600 IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fdta(:,:,:,2), & 601 & sdjf%nrec_a(1), sdjf%lsmname ) 602 ELSE ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fnow(:,:,: ), & 603 & sdjf%nrec_a(1), sdjf%lsmname ) 595 604 ENDIF 596 605 ELSE … … 856 865 sdf(jf)%wgtname = " " 857 866 IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )//TRIM( sdf_n(jf)%wname ) 867 sdf(jf)%lsmname = " " 868 IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 ) sdf(jf)%lsmname = TRIM( cdir )//TRIM( sdf_n(jf)%lname ) 858 869 sdf(jf)%vcomp = sdf_n(jf)%vcomp 859 870 sdf(jf)%rotn(:) = .TRUE. ! pretend to be rotated -> won't try to rotate data before the first call to fld_get … … 878 889 & ' weights : ' , TRIM( sdf(jf)%wgtname ), & 879 890 & ' pairing : ' , TRIM( sdf(jf)%vcomp ), & 880 & ' data type: ' , sdf(jf)%cltype 891 & ' data type: ' , sdf(jf)%cltype , & 892 & ' land/sea mask:' , TRIM( sdf(jf)%lsmname ) 881 893 call flush(numout) 882 894 END DO … … 1098 1110 1099 1111 1100 SUBROUTINE fld_interp( num, clvar, kw, kk, dta, nrec ) 1112 SUBROUTINE apply_seaoverland(clmaskfile,zfieldo,jpi1_lsm,jpi2_lsm,jpj1_lsm, & 1113 & jpj2_lsm,itmpi,itmpj,itmpz,rec1_lsm,recn_lsm) 1114 !!--------------------------------------------------------------------- 1115 !! *** ROUTINE apply_seaoverland *** 1116 !! 1117 !! ** Purpose : avoid spurious fluxes in coastal or near-coastal areas 1118 !! due to the wrong usage of "land" values from the coarse 1119 !! atmospheric model when spatial interpolation is required 1120 !! D. Delrosso INGV 1121 !!---------------------------------------------------------------------- 1122 INTEGER :: inum,jni,jnj,jnz,jc ! temporary indices 1123 INTEGER, INTENT(in) :: itmpi,itmpj,itmpz ! lengths 1124 INTEGER, INTENT(in) :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices 1125 INTEGER, DIMENSION(3), INTENT(in) :: rec1_lsm,recn_lsm ! temporary arrays for start and length 1126 REAL(wp),DIMENSION (:,:,:),INTENT(inout) :: zfieldo ! input/output array for seaoverland application 1127 REAL(wp),DIMENSION (:,:,:),ALLOCATABLE :: zslmec1 ! temporary array for land point detection 1128 REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfieldn ! array of forcing field with undeff for land points 1129 REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfield ! array of forcing field 1130 CHARACTER (len=100), INTENT(in) :: clmaskfile ! land/sea mask file name 1131 !!--------------------------------------------------------------------- 1132 ALLOCATE ( zslmec1(itmpi,itmpj,itmpz) ) 1133 ALLOCATE ( zfieldn(itmpi,itmpj) ) 1134 ALLOCATE ( zfield(itmpi,itmpj) ) 1135 1136 ! Retrieve the land sea mask data 1137 CALL iom_open( clmaskfile, inum ) 1138 SELECT CASE( SIZE(zfieldo(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) ) 1139 CASE(1) 1140 CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), 1, rec1_lsm, recn_lsm) 1141 CASE DEFAULT 1142 CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), 1, rec1_lsm, recn_lsm) 1143 END SELECT 1144 CALL iom_close( inum ) 1145 1146 DO jnz=1,rec1_lsm(3) !! Loop over k dimension 1147 1148 DO jni=1,itmpi !! copy the original field into a tmp array 1149 DO jnj=1,itmpj !! substituting undeff over land points 1150 zfieldn(jni,jnj) = zfieldo(jni,jnj,jnz) 1151 IF ( zslmec1(jni,jnj,jnz) == 1. ) THEN 1152 zfieldn(jni,jnj) = undeff_lsm 1153 ENDIF 1154 END DO 1155 END DO 1156 1157 CALL seaoverland(zfieldn,itmpi,itmpj,zfield) 1158 DO jc=1,nn_lsm 1159 CALL seaoverland(zfield,itmpi,itmpj,zfield) 1160 END DO 1161 1162 ! Check for Undeff and substitute original values 1163 IF(ANY(zfield==undeff_lsm)) THEN 1164 DO jni=1,itmpi 1165 DO jnj=1,itmpj 1166 IF (zfield(jni,jnj)==undeff_lsm) THEN 1167 zfield(jni,jnj) = zfieldo(jni,jnj,jnz) 1168 ENDIF 1169 ENDDO 1170 ENDDO 1171 ENDIF 1172 1173 zfieldo(:,:,jnz)=zfield(:,:) 1174 1175 END DO !! End Loop over k dimension 1176 1177 DEALLOCATE ( zslmec1 ) 1178 DEALLOCATE ( zfieldn ) 1179 DEALLOCATE ( zfield ) 1180 1181 END SUBROUTINE apply_seaoverland 1182 1183 1184 SUBROUTINE seaoverland(zfieldn,ileni,ilenj,zfield) 1185 !!--------------------------------------------------------------------- 1186 !! *** ROUTINE seaoverland *** 1187 !! 1188 !! ** Purpose : create shifted matrices for seaoverland application 1189 !! D. Delrosso INGV 1190 !!---------------------------------------------------------------------- 1191 INTEGER,INTENT(in) :: ileni,ilenj ! lengths 1192 REAL,DIMENSION (ileni,ilenj),INTENT(in) :: zfieldn ! array of forcing field with undeff for land points 1193 REAL,DIMENSION (ileni,ilenj),INTENT(out) :: zfield ! array of forcing field 1194 REAL,DIMENSION (ileni,ilenj) :: zmat1,zmat2,zmat3,zmat4 ! temporary arrays for seaoverland application 1195 REAL,DIMENSION (ileni,ilenj) :: zmat5,zmat6,zmat7,zmat8 ! temporary arrays for seaoverland application 1196 REAL,DIMENSION (ileni,ilenj) :: zlsm2d ! temporary arrays for seaoverland application 1197 REAL,DIMENSION (ileni,ilenj,8) :: zlsm3d ! temporary arrays for seaoverland application 1198 LOGICAL,DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection 1199 LOGICAL,DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection 1200 !!---------------------------------------------------------------------- 1201 zmat8 = eoshift(zfieldn , SHIFT=-1, BOUNDARY = (/zfieldn(:,1)/) ,DIM=2) 1202 zmat1 = eoshift(zmat8 , SHIFT=-1, BOUNDARY = (/zmat8(1,:)/) ,DIM=1) 1203 zmat2 = eoshift(zfieldn , SHIFT=-1, BOUNDARY = (/zfieldn(1,:)/) ,DIM=1) 1204 zmat4 = eoshift(zfieldn , SHIFT= 1, BOUNDARY = (/zfieldn(:,ilenj)/),DIM=2) 1205 zmat3 = eoshift(zmat4 , SHIFT=-1, BOUNDARY = (/zmat4(1,:)/) ,DIM=1) 1206 zmat5 = eoshift(zmat4 , SHIFT= 1, BOUNDARY = (/zmat4(ileni,:)/) ,DIM=1) 1207 zmat6 = eoshift(zfieldn , SHIFT= 1, BOUNDARY = (/zfieldn(ileni,:)/),DIM=1) 1208 zmat7 = eoshift(zmat8 , SHIFT= 1, BOUNDARY = (/zmat8(ileni,:)/) ,DIM=1) 1209 1210 zlsm3d = RESHAPE( (/ zmat1, zmat2, zmat3, zmat4, zmat5, zmat6, zmat7, zmat8 /), (/ ileni, ilenj, 8 /)) 1211 ll_msknan3d = .not.(zlsm3d==undeff_lsm) 1212 ll_msknan2d = .not.(zfieldn==undeff_lsm) ! FALSE where is Undeff (land) 1213 zlsm2d = (SUM ( zlsm3d, 3 , ll_msknan3d ) )/(MAX(1,(COUNT( ll_msknan3d , 3 )) )) 1214 WHERE ((COUNT( ll_msknan3d , 3 )) == 0.0_wp) zlsm2d = undeff_lsm 1215 zfield = MERGE (zfieldn,zlsm2d,ll_msknan2d) 1216 END SUBROUTINE seaoverland 1217 1218 1219 SUBROUTINE fld_interp( num, clvar, kw, kk, dta, & 1220 & nrec, lsmfile) 1101 1221 !!--------------------------------------------------------------------- 1102 1222 !! *** ROUTINE fld_interp *** … … 1111 1231 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: dta ! output field on model grid 1112 1232 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 1233 CHARACTER(LEN=*) , INTENT(in ) :: lsmfile ! land sea mask file name 1113 1234 !! 1114 INTEGER, DIMENSION(3) :: rec1,recn ! temporary arrays for start and length 1115 INTEGER :: jk, jn, jm ! loop counters 1116 INTEGER :: ni, nj ! lengths 1117 INTEGER :: jpimin,jpiwid ! temporary indices 1118 INTEGER :: jpjmin,jpjwid ! temporary indices 1119 INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices 1235 REAL(wp),DIMENSION(:,:,:),ALLOCATABLE :: ztmp_fly_dta,zfieldo ! temporary array of values on input grid 1236 INTEGER, DIMENSION(3) :: rec1,recn ! temporary arrays for start and length 1237 INTEGER, DIMENSION(3) :: rec1_lsm,recn_lsm ! temporary arrays for start and length in case of seaoverland 1238 INTEGER :: ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2 ! temporary indices 1239 INTEGER :: jk, jn, jm, jir, jjr ! loop counters 1240 INTEGER :: ni, nj ! lengths 1241 INTEGER :: jpimin,jpiwid ! temporary indices 1242 INTEGER :: jpimin_lsm,jpiwid_lsm ! temporary indices 1243 INTEGER :: jpjmin,jpjwid ! temporary indices 1244 INTEGER :: jpjmin_lsm,jpjwid_lsm ! temporary indices 1245 INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices 1246 INTEGER :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices 1247 INTEGER :: itmpi,itmpj,itmpz ! lengths 1248 1120 1249 !!---------------------------------------------------------------------- 1121 1250 ! … … 1147 1276 jpj2 = jpj1 + recn(2) - 1 1148 1277 1149 ref_wgts(kw)%fly_dta(:,:,:) = 0.0 1150 SELECT CASE( SIZE(ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:),3) ) 1151 CASE(1) 1152 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,1), nrec, rec1, recn) 1153 CASE DEFAULT 1154 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, rec1, recn) 1155 END SELECT 1278 1279 IF( LEN( TRIM(lsmfile) ) > 0 ) THEN 1280 !! indeces for ztmp_fly_dta 1281 ! -------------------------- 1282 rec1_lsm(1)=MAX(rec1(1)-nn_lsm,1) ! starting index for enlarged external data, x direction 1283 rec1_lsm(2)=MAX(rec1(2)-nn_lsm,1) ! starting index for enlarged external data, y direction 1284 rec1_lsm(3) = 1 ! vertical dimension 1285 recn_lsm(1)=MIN(rec1(1)-rec1_lsm(1)+recn(1)+nn_lsm,ref_wgts(kw)%ddims(1)-rec1_lsm(1)) ! n points in x direction 1286 recn_lsm(2)=MIN(rec1(2)-rec1_lsm(2)+recn(2)+nn_lsm,ref_wgts(kw)%ddims(2)-rec1_lsm(2)) ! n points in y direction 1287 recn_lsm(3) = kk ! number of vertical levels in the input file 1288 1289 ! Avoid out of bound 1290 jpimin_lsm = MAX( rec1_lsm(1)+1, 1 ) 1291 jpjmin_lsm = MAX( rec1_lsm(2)+1, 1 ) 1292 jpiwid_lsm = MIN( recn_lsm(1)-2,ref_wgts(kw)%ddims(1)-rec1(1)+1) 1293 jpjwid_lsm = MIN( recn_lsm(2)-2,ref_wgts(kw)%ddims(2)-rec1(2)+1) 1294 1295 jpi1_lsm = 2+rec1_lsm(1)-jpimin_lsm 1296 jpj1_lsm = 2+rec1_lsm(2)-jpjmin_lsm 1297 jpi2_lsm = jpi1_lsm + recn_lsm(1) - 1 1298 jpj2_lsm = jpj1_lsm + recn_lsm(2) - 1 1299 1300 1301 itmpi=SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),1) 1302 itmpj=SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),2) 1303 itmpz=kk 1304 ALLOCATE(ztmp_fly_dta(itmpi,itmpj,itmpz)) 1305 ztmp_fly_dta(:,:,:) = 0.0 1306 SELECT CASE( SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) ) 1307 CASE(1) 1308 CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), & 1309 & nrec, rec1_lsm, recn_lsm) 1310 CASE DEFAULT 1311 CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & 1312 & nrec, rec1_lsm, recn_lsm) 1313 END SELECT 1314 CALL apply_seaoverland(lsmfile,ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & 1315 & jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm, & 1316 & itmpi,itmpj,itmpz,rec1_lsm,recn_lsm) 1317 1318 1319 ! Relative indeces for remapping 1320 ii_lsm1 = (rec1(1)-rec1_lsm(1))+1 1321 ii_lsm2 = (ii_lsm1+recn(1))-1 1322 ij_lsm1 = (rec1(2)-rec1_lsm(2))+1 1323 ij_lsm2 = (ij_lsm1+recn(2))-1 1324 1325 ref_wgts(kw)%fly_dta(:,:,:) = 0.0 1326 ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:) = ztmp_fly_dta(ii_lsm1:ii_lsm2,ij_lsm1:ij_lsm2,:) 1327 DEALLOCATE(ztmp_fly_dta) 1328 1329 ELSE 1330 1331 ref_wgts(kw)%fly_dta(:,:,:) = 0.0 1332 SELECT CASE( SIZE(ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:),3) ) 1333 CASE(1) 1334 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,1), nrec, rec1, recn) 1335 CASE DEFAULT 1336 CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, rec1, recn) 1337 END SELECT 1338 ENDIF 1339 1156 1340 1157 1341 !! first four weights common to both bilinear and bicubic -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90
r4205 r4230 37 37 LOGICAL , PUBLIC :: ln_cpl !: coupled formulation (overwritten by key_sbc_coupled ) 38 38 LOGICAL , PUBLIC :: ln_dm2dc !: Daily mean to Diurnal Cycle short wave (qsr) 39 LOGICAL , PUBLIC :: ln_rnf = .FALSE.!: runoffs / runoff mouths39 LOGICAL , PUBLIC :: ln_rnf !: runoffs / runoff mouths 40 40 LOGICAL , PUBLIC :: ln_ssr !: Sea Surface restoring on SST and/or SSS 41 41 LOGICAL , PUBLIC :: ln_apr_dyn !: Atmospheric pressure forcing used on dynamics (ocean & ice) … … 55 55 LOGICAL , PUBLIC :: ln_icebergs !: Icebergs 56 56 ! 57 CHARACTER (len=8), PUBLIC :: cn_iceflx = 'none'!: Flux handling over ice categories58 LOGICAL, PUBLIC :: ln_iceflx_ave = .FALSE.! Average heat fluxes over all ice categories59 LOGICAL, PUBLIC :: ln_iceflx_linear = .FALSE.! Redistribute mean heat fluxes over all ice categories, using ice temperature and albedo57 CHARACTER (len=8), PUBLIC :: cn_iceflx !: Flux handling over ice categories 58 LOGICAL, PUBLIC :: ln_iceflx_ave ! Average heat fluxes over all ice categories 59 LOGICAL, PUBLIC :: ln_iceflx_linear ! Redistribute mean heat fluxes over all ice categories, using ice temperature and albedo 60 60 ! 61 INTEGER , PUBLIC :: nn_lsm !: Number of iteration if seaoverland is applied 61 62 !!---------------------------------------------------------------------- 62 63 !! Ocean Surface Boundary Condition fields -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcapr.F90
r4147 r4230 76 76 ! ! -------------------- ! 77 77 IF( kt == nit000 ) THEN ! First call kt=nit000 ! 78 ! ! -------------------- ! 79 78 ! ! -------------------- ! 80 79 REWIND( numnam_ref ) ! Namelist namsbc_apr in reference namelist : File for atmospheric pressure forcing 81 80 READ ( numnam_ref, namsbc_apr, IOSTAT = ios, ERR = 901) -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
r4161 r4230 141 141 ! ! ====================== ! 142 142 ! 143 144 143 REWIND( numnam_ref ) ! Namelist namsbc_core in reference namelist : CORE bulk parameters 145 144 READ ( numnam_ref, namsbc_core, IOSTAT = ios, ERR = 901) -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90
r4147 r4230 734 734 & sn_top1, sn_top2, sn_top3, sn_top4, sn_top5, & 735 735 & sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5 736 INTEGER :: ios 736 737 !!--------------------------------------------------------------------- 737 738 … … 739 740 IF( kt == nit000 ) THEN ! First call kt=nit000 ! 740 741 ! ! ====================== ! 741 ! set file information (default values) 742 cn_dir = './' ! directory in which the model is executed 743 744 ! (NB: frequency positive => hours, negative => months) 745 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! 746 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! 747 sn_snow = FLD_N( 'snowfall_1m' , -1. , 'snowfall' , .true. , .true. , ' yearly' , '' , '' ) 748 sn_rain = FLD_N( 'rainfall_1m' , -1. , 'rainfall' , .true. , .true. , ' yearly' , '' , '' ) 749 sn_sblm = FLD_N( 'sublim_1m' , -1. , 'sublim' , .true. , .true. , ' yearly' , '' , '' ) 750 sn_top1 = FLD_N( 'topmeltn1_1m' , -1. , 'topmeltn1' , .true. , .true. , ' yearly' , '' , '' ) 751 sn_top2 = FLD_N( 'topmeltn2_1m' , -1. , 'topmeltn2' , .true. , .true. , ' yearly' , '' , '' ) 752 sn_top3 = FLD_N( 'topmeltn3_1m' , -1. , 'topmeltn3' , .true. , .true. , ' yearly' , '' , '' ) 753 sn_top4 = FLD_N( 'topmeltn4_1m' , -1. , 'topmeltn4' , .true. , .true. , ' yearly' , '' , '' ) 754 sn_top5 = FLD_N( 'topmeltn5_1m' , -1. , 'topmeltn5' , .true. , .true. , ' yearly' , '' , '' ) 755 sn_bot1 = FLD_N( 'botmeltn1_1m' , -1. , 'botmeltn1' , .true. , .true. , ' yearly' , '' , '' ) 756 sn_bot2 = FLD_N( 'botmeltn2_1m' , -1. , 'botmeltn2' , .true. , .true. , ' yearly' , '' , '' ) 757 sn_bot3 = FLD_N( 'botmeltn3_1m' , -1. , 'botmeltn3' , .true. , .true. , ' yearly' , '' , '' ) 758 sn_bot4 = FLD_N( 'botmeltn4_1m' , -1. , 'botmeltn4' , .true. , .true. , ' yearly' , '' , '' ) 759 sn_bot5 = FLD_N( 'botmeltn5_1m' , -1. , 'botmeltn5' , .true. , .true. , ' yearly' , '' , '' ) 760 761 ! ... at some point might read in from NEMO namelist? 762 !!$ REWIND( numnam_ref ) ! Namelist namsbc_cice in reference namelist : 763 !!$ READ ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901) 764 !!$901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist', lwp ) 765 !!$ 766 !!$ REWIND( numnam_cfg ) ! Namelist namsbc_cice in configuration namelist : Parameters of the run 767 !!$ READ ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 ) 768 !!$902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist', lwp ) 769 !!$ WRITE ( numond, namsbc_cice ) 742 REWIND( numnam_ref ) ! Namelist namsbc_cice in reference namelist : 743 READ ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901) 744 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist', lwp ) 745 746 REWIND( numnam_cfg ) ! Namelist namsbc_cice in configuration namelist : Parameters of the run 747 READ ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 ) 748 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist', lwp ) 749 WRITE ( numond, namsbc_cice ) 770 750 771 751 ! store namelist information in an array -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r4205 r4230 84 84 NAMELIST/namsbc/ nn_fsbc , ln_ana , ln_flx, ln_blk_clio, ln_blk_core, ln_cpl, & 85 85 & ln_blk_mfs, ln_apr_dyn, nn_ice, nn_ice_embd, ln_dm2dc , ln_rnf, & 86 & ln_ssr , nn_fwb , ln_cdgw , ln_wave , ln_sdw, cn_iceflx86 & ln_ssr , nn_fwb , ln_cdgw , ln_wave , ln_sdw, nn_lsm, cn_iceflx 87 87 INTEGER :: ios 88 88 !!---------------------------------------------------------------------- … … 134 134 WRITE(numout,*) ' FreshWater Budget control (=0/1/2) nn_fwb = ', nn_fwb 135 135 WRITE(numout,*) ' closed sea (=0/1) (set in namdom) nn_closea = ', nn_closea 136 WRITE(numout,*) ' n. of iterations if land-sea-mask applied nn_lsm = ', nn_lsm 136 137 ENDIF 137 138 -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90
r4147 r4230 83 83 IF( kt == nit000 ) THEN ! First call kt=nit000 ! 84 84 ! ! -------------------- ! 85 86 85 REWIND( numnam_ref ) ! Namelist namsbc_wave in reference namelist : File for drag coeff. from wave model 87 86 READ ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r3294 r4230 104 104 IF(lwp) WRITE(numout,*) '~~~~~~~' 105 105 ! 106 rbcp = 0.25 * (1. + atfp) * (1. + atfp) * ( 1.- atfp) ! Brown & Campana parameter for semi-implicit hpg106 rbcp = 0.25_wp * (1._wp + atfp) * (1._wp + atfp) * ( 1._wp - atfp) ! Brown & Campana parameter for semi-implicit hpg 107 107 ENDIF 108 108 109 109 ! Update after tracer on domain lateral boundaries 110 110 ! 111 CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) ! local domain boundaries (T-point, unchanged sign)112 CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. )111 CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp ) ! local domain boundaries (T-point, unchanged sign) 112 CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) 113 113 ! 114 114 #if defined key_obc … … 124 124 ! set time step size (Euler/Leapfrog) 125 125 IF( neuler == 0 .AND. kt == nit000 ) THEN ; r2dtra(:) = rdttra(:) ! at nit000 (Euler) 126 ELSEIF( kt <= nit000 + 1 ) THEN ; r2dtra(:) = 2. * rdttra(:) ! at nit000 or nit000+1 (Leapfrog)126 ELSEIF( kt <= nit000 + 1 ) THEN ; r2dtra(:) = 2._wp* rdttra(:) ! at nit000 or nit000+1 (Leapfrog) 127 127 ENDIF 128 128 … … 155 155 IF( l_trdtra ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt 156 156 DO jk = 1, jpkm1 157 zfact = 1.e0 / r2dtra(jk)157 zfact = 1.e0_wp / r2dtra(jk) 158 158 ztrdt(:,:,jk) = ( tsb(:,:,jk,jp_tem) - ztrdt(:,:,jk) ) * zfact 159 159 ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r4152 r4230 86 86 USE sbctide, ONLY: lk_tide 87 87 USE crsini ! initialise grid coarsening utility 88 USE lbcnfd, ONLY: isendto, nsndto ! Setup of north fold exchanges 88 89 89 90 IMPLICIT NONE … … 755 756 !!====================================================================== 756 757 !! *** ROUTINE nemo_northcomms *** 757 !! nemo_northcomms : Setup for north fold exchanges with explicit peer to peer messaging 758 !! nemo_northcomms : Setup for north fold exchanges with explicit 759 !! point-to-point messaging 758 760 !!===================================================================== 759 761 !!---------------------------------------------------------------------- … … 762 764 !!---------------------------------------------------------------------- 763 765 !! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) 764 !!---------------------------------------------------------------------- 765 766 INTEGER :: ji, jj, jk, ij, jtyp ! dummy loop indices 767 INTEGER :: ijpj ! number of rows involved in north-fold exchange 768 INTEGER :: northcomms_alloc ! allocate return status 769 REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) :: znnbrs ! workspace 770 LOGICAL, ALLOCATABLE, DIMENSION ( : ) :: lrankset ! workspace 771 772 IF(lwp) WRITE(numout,*) 773 IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists' 774 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 775 776 !!---------------------------------------------------------------------- 777 ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc ) 778 ALLOCATE( lrankset(jpnij), stat = northcomms_alloc ) 779 IF( northcomms_alloc /= 0 ) THEN 780 WRITE(numout,cform_war) 781 WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays' 782 CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' ) 783 ENDIF 766 !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC) 767 !!---------------------------------------------------------------------- 768 769 INTEGER :: sxM, dxM, sxT, dxT, jn 770 INTEGER :: njmppmax 771 772 njmppmax = MAXVAL( njmppt ) 773 774 !initializes the north-fold communication variables 775 isendto(:) = 0 784 776 nsndto = 0 785 isendto = -1 786 ijpj = 4 787 ! 788 ! This routine has been called because ln_nnogather has been set true ( nammpp ) 789 ! However, these first few exchanges have to use the mpi_allgather method to 790 ! establish the neighbour lists to use in subsequent peer to peer exchanges. 791 ! Consequently, set l_north_nogather to be false here and set it true only after 792 ! the lists have been established. 793 ! 794 l_north_nogather = .FALSE. 795 ! 796 ! Exchange and store ranks on northern rows 797 798 DO jtyp = 1,4 799 800 lrankset = .FALSE. 801 znnbrs = narea 802 SELECT CASE (jtyp) 803 CASE(1) 804 CALL lbc_lnk( znnbrs, 'T', 1. ) ! Type 1: T,W-points 805 CASE(2) 806 CALL lbc_lnk( znnbrs, 'U', 1. ) ! Type 2: U-point 807 CASE(3) 808 CALL lbc_lnk( znnbrs, 'V', 1. ) ! Type 3: V-point 809 CASE(4) 810 CALL lbc_lnk( znnbrs, 'F', 1. ) ! Type 4: F-point 811 END SELECT 812 813 IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN 814 DO jj = nlcj-ijpj+1, nlcj 815 ij = jj - nlcj + ijpj 816 DO ji = 1,jpi 817 IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 818 & lrankset(INT(znnbrs(ji,jj))) = .true. 819 END DO 820 END DO 821 822 DO jj = 1,jpnij 823 IF ( lrankset(jj) ) THEN 824 nsndto(jtyp) = nsndto(jtyp) + 1 825 IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN 826 CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 827 & ' jpmaxngh will need to be increased ') 828 ENDIF 829 isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank 830 ENDIF 831 END DO 832 ENDIF 833 834 END DO 835 836 ! 837 ! Type 5: I-point 838 ! 839 ! ICE point exchanges may involve some averaging. The neighbours list is 840 ! built up using two exchanges to ensure that the whole stencil is covered. 841 ! lrankset should not be reset between these 'J' and 'K' point exchanges 842 843 jtyp = 5 844 lrankset = .FALSE. 845 znnbrs = narea 846 CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point 847 848 IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN 849 DO jj = nlcj-ijpj+1, nlcj 850 ij = jj - nlcj + ijpj 851 DO ji = 1,jpi 852 IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 853 & lrankset(INT(znnbrs(ji,jj))) = .true. 854 END DO 855 END DO 856 ENDIF 857 858 znnbrs = narea 859 CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point 860 861 IF ( njmppt(narea) .EQ. MAXVAL( njmppt )) THEN 862 DO jj = nlcj-ijpj+1, nlcj 863 ij = jj - nlcj + ijpj 864 DO ji = 1,jpi 865 IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 866 & lrankset( INT(znnbrs(ji,jj))) = .true. 867 END DO 868 END DO 869 870 DO jj = 1,jpnij 871 IF ( lrankset(jj) ) THEN 872 nsndto(jtyp) = nsndto(jtyp) + 1 873 IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN 874 CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 875 & ' jpmaxngh will need to be increased ') 876 ENDIF 877 isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank 878 ENDIF 879 END DO 880 ! 881 ! For northern row areas, set l_north_nogather so that all subsequent exchanges 882 ! can use peer to peer communications at the north fold 883 ! 884 l_north_nogather = .TRUE. 885 ! 886 ENDIF 887 DEALLOCATE( znnbrs ) 888 DEALLOCATE( lrankset ) 889 777 778 !if I am a process in the north 779 IF ( njmpp == njmppmax ) THEN 780 !sxM is the first point (in the global domain) needed to compute the 781 !north-fold for the current process 782 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1 783 !dxM is the last point (in the global domain) needed to compute the 784 !north-fold for the current process 785 dxM = jpiglo - nimppt(narea) + 2 786 787 !loop over the other north-fold processes to find the processes 788 !managing the points belonging to the sxT-dxT range 789 DO jn = jpnij - jpni +1, jpnij 790 IF ( njmppt(jn) == njmppmax ) THEN 791 !sxT is the first point (in the global domain) of the jn 792 !process 793 sxT = nimppt(jn) 794 !dxT is the last point (in the global domain) of the jn 795 !process 796 dxT = nimppt(jn) + nlcit(jn) - 1 797 IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN 798 nsndto = nsndto + 1 799 isendto(nsndto) = jn 800 ELSEIF ((sxM .le. sxT) .AND. (dxM .gt. dxT)) THEN 801 nsndto = nsndto + 1 802 isendto(nsndto) = jn 803 ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN 804 nsndto = nsndto + 1 805 isendto(nsndto) = jn 806 END IF 807 END IF 808 END DO 809 ENDIF 810 l_north_nogather = .TRUE. 890 811 END SUBROUTINE nemo_northcomms 891 812 #else -
branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/step.F90
r4215 r4230 193 193 tsa(:,:,:,:) = 0.e0 ! set tracer trends to zero 194 194 195 !write(numout,*) "MAV kt",kstp 196 !write(numout,'(a5,3(1x,f21.18))') "INIn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11) 197 !write(numout,'(a5,3(1x,f21.18))') "INIa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 195 198 IF( ln_asmiau .AND. & 196 199 & ln_trainc ) CALL tra_asm_inc( kstp ) ! apply tracer assimilation increment … … 202 205 IF( lk_bdy ) CALL bdy_tra_dmp( kstp ) ! bdy damping trends 203 206 CALL tra_adv ( kstp ) ! horizontal & vertical advection 207 !write(numout,'(a5,3(1x,f21.18))') "ADVn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11) 208 !write(numout,'(a5,3(1x,f21.18))') "ADVa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 204 209 IF( lk_zdfkpp ) CALL tra_kpp ( kstp ) ! KPP non-local tracer fluxes 205 210 CALL tra_ldf ( kstp ) ! lateral mixing 211 !write(numout,'(a5,3(1x,f21.18))') "LDFn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11) 212 !write(numout,'(a5,3(1x,f21.18))') "LDFa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 206 213 #if defined key_agrif 207 214 IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_tra ! tracers sponge 208 215 #endif 209 216 CALL tra_zdf ( kstp ) ! vertical mixing and after tracer fields 217 !do jk=1,jpk 218 !write(numout,'(a5,3(1x,f21.18))') "ZDFn:",tsn(5,10,jk,jp_tem),tsn(5,10,jk,jp_sal),tmask(5,10,jk) 219 !write(numout,'(a5,3(1x,f21.18))') "ZDFa:",tsa(5,10,jk,jp_tem),tsa(5,10,jk,jp_sal),ssha(5,10) 220 !end do 210 221 211 222 IF( ln_dynhpg_imp ) THEN ! semi-implicit hpg (time stepping then eos) … … 220 231 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv, & ! zps: now hor. derivative 221 232 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 233 !write(numout,'(a5,3(1x,f21.18))') "ZPSn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11) 234 !write(numout,'(a5,3(1x,f21.18))') "ZPSa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 222 235 IF( ln_zdfnpc ) CALL tra_npc( kstp ) ! update after fields by non-penetrative convection 223 236 CALL tra_nxt( kstp ) ! tracer fields at next time step 237 !write(numout,'(a5,3(1x,f21.18))') "NXTn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(25,11) 238 !write(numout,'(a5,3(1x,f21.18))') "NXTa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 224 239 ENDIF 225 240
Note: See TracChangeset
for help on using the changeset viewer.
