Changeset 5372 for branches/2015
- Timestamp:
- 2015-06-05T21:14:36+02:00 (9 years ago)
- Location:
- branches/2015/dev_r5302_CNRS18_HPC_scalability/NEMOGCM/NEMO
- Files:
-
- 5 edited
-
LIM_SRC_3/limadv.F90 (modified) (4 diffs)
-
LIM_SRC_3/limrhg.F90 (modified) (6 diffs)
-
OPA_SRC/DYN/dynspg_ts.F90 (modified) (4 diffs)
-
OPA_SRC/LBC/lbclnk.F90 (modified) (2 diffs)
-
OPA_SRC/LBC/lib_mpp.F90 (modified) (3 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5302_CNRS18_HPC_scalability/NEMOGCM/NEMO/LIM_SRC_3/limadv.F90
r5123 r5372 206 206 END DO 207 207 208 209 #if defined key_multisend 210 CALL lbc_lnk_multi( psm , 'T', 1. , ps0 , 'T', 1. , psx , 'T', -1. , psy , 'T', -1. , psxx, 'T', 1. , psyy, 'T', 1. , psxy, 'T', 1. ) 211 #else 208 212 !-- Lateral boundary conditions 209 213 CALL lbc_lnk( psm , 'T', 1. ) ; CALL lbc_lnk( ps0 , 'T', 1. ) … … 211 215 CALL lbc_lnk( psxx, 'T', 1. ) ; CALL lbc_lnk( psyy, 'T', 1. ) 212 216 CALL lbc_lnk( psxy, 'T', 1. ) 217 #endif 213 218 214 219 IF(ln_ctl) THEN … … 392 397 END DO 393 398 399 #if defined key_multisend 400 CALL lbc_lnk_multi( psm , 'T', 1. , ps0 , 'T', 1. , psx , 'T', -1. , psy , 'T', -1. , psxx, 'T', 1. , psyy, 'T', 1. , psxy, 'T', 1. ) 401 #else 394 402 !-- Lateral boundary conditions 395 403 CALL lbc_lnk( psm , 'T', 1. ) ; CALL lbc_lnk( ps0 , 'T', 1. ) … … 397 405 CALL lbc_lnk( psxx, 'T', 1. ) ; CALL lbc_lnk( psyy, 'T', 1. ) 398 406 CALL lbc_lnk( psxy, 'T', 1. ) 407 #endif 408 399 409 400 410 IF(ln_ctl) THEN -
branches/2015/dev_r5302_CNRS18_HPC_scalability/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90
r5123 r5372 377 377 END DO 378 378 END DO 379 CALL lbc_lnk( v_ice1 , 'U', -1. ) ; CALL lbc_lnk( u_ice2 , 'V', -1. ) ! lateral boundary cond. 379 380 381 #if defined key_multisend 382 CALL lbc_lnk_multi( v_ice1, 'U', -1. , u_ice2, 'V', -1. ) ! lateral boundary cond. 383 #else 384 CALL lbc_lnk( v_ice1, 'U', -1. ) ; CALL lbc_lnk( u_ice2, 'V', -1. ) ! lateral boundary cond. 385 #endif 380 386 381 387 DO jj = k_j1+1, k_jpj-1 … … 412 418 END DO 413 419 END DO 420 421 #if defined key_multisend 422 CALL lbc_lnk_multi( zs1 , 'T', 1. , zs2, 'T', 1. , zs12, 'F', 1. ) 423 424 #else 414 425 CALL lbc_lnk( zs1 , 'T', 1. ) ; CALL lbc_lnk( zs2, 'T', 1. ) 415 426 CALL lbc_lnk( zs12, 'F', 1. ) 427 #endif 428 416 429 417 430 ! Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) … … 570 583 END DO 571 584 572 CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 573 CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 585 #if defined key_multisend 586 CALL lbc_lnk_multi( u_ice(:,:), 'U', -1. , v_ice(:,:), 'V', -1. ) 587 588 #else 589 CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 590 CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 591 #endif 592 574 593 #if defined key_agrif && defined key_lim2 575 594 CALL agrif_rhg_lim2( nn_nevp , nn_nevp, 'U' ) … … 595 614 END DO 596 615 597 CALL lbc_lnk( u_ice2(:,:), 'V', -1. ) 616 #if defined key_multisend 617 CALL lbc_lnk_multi( u_ice2(:,:), 'V', -1. , v_ice1(:,:), 'U', -1. ) 618 619 #else 620 CALL lbc_lnk( u_ice2(:,:), 'V', -1. ) 598 621 CALL lbc_lnk( v_ice1(:,:), 'U', -1. ) 622 #endif 599 623 600 624 ! Recompute delta, shear and div, inputs for mechanical redistribution … … 642 666 END DO 643 667 668 #if defined key_multisend 669 ! Lateral boundary condition 670 CALL lbc_lnk_multi( divu_i (:,:), 'T', 1. , delta_i(:,:), 'T', 1. , shear_i(:,:), 'T', 1. ) 671 ! CALL lbc_lnk( shear_i(:,:), 'F', 1. ) 672 673 #else 644 674 ! Lateral boundary condition 645 675 CALL lbc_lnk( divu_i (:,:), 'T', 1. ) … … 647 677 ! CALL lbc_lnk( shear_i(:,:), 'F', 1. ) 648 678 CALL lbc_lnk( shear_i(:,:), 'T', 1. ) 679 #endif 649 680 650 681 ! * Store the stress tensor for the next time step -
branches/2015/dev_r5302_CNRS18_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r5217 r5372 557 557 END DO 558 558 END DO 559 #if defined key_multisend 560 CALL lbc_lnk_multi( zwx, 'U', 1._wp , zwy, 'V', 1._wp ) 561 #else 559 562 CALL lbc_lnk( zwx, 'U', 1._wp ) ; CALL lbc_lnk( zwy, 'V', 1._wp ) 563 #endif 560 564 ! 561 565 zhup2_e (:,:) = hu_0(:,:) + zwx(:,:) ! Ocean depth at U- and V-points … … 635 639 END DO 636 640 END DO 641 #if defined key_multisend 642 CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp , zsshv_a, 'V', 1._wp ) 643 #else 637 644 CALL lbc_lnk( zsshu_a, 'U', 1._wp ) ; CALL lbc_lnk( zsshv_a, 'V', 1._wp ) 645 #endif 638 646 ENDIF 639 647 ! … … 803 811 ! ! ----------------------- 804 812 ! 813 #if defined key_multisend 814 CALL lbc_lnk_multi( ua_e, 'U', -1._wp , va_e , 'V', -1._wp ) 815 #else 805 816 CALL lbc_lnk( ua_e , 'U', -1._wp ) ! local domain boundaries 806 817 CALL lbc_lnk( va_e , 'V', -1._wp ) 818 #endif 819 820 807 821 808 822 #if defined key_bdy … … 859 873 END DO 860 874 END DO 875 #if defined key_multisend 876 CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp , zsshv_a, 'V', 1._wp ) ! Boundary conditions 877 #else 861 878 CALL lbc_lnk( zsshu_a, 'U', 1._wp ) ; CALL lbc_lnk( zsshv_a, 'V', 1._wp ) ! Boundary conditions 879 #endif 862 880 ENDIF 863 881 ! -
branches/2015/dev_r5302_CNRS18_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r4990 r5372 22 22 USE lib_mpp ! distributed memory computing library 23 23 24 25 #if defined key_multisend 26 INTERFACE lbc_lnk_multi 27 MODULE PROCEDURE mpp_lnk_2d_9 28 END INTERFACE 29 #endif 30 24 31 INTERFACE lbc_lnk 25 32 MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d … … 39 46 40 47 PUBLIC lbc_lnk ! ocean lateral boundary conditions 48 #if defined key_multisend 49 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 50 #endif 41 51 PUBLIC lbc_lnk_e 42 52 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions -
branches/2015/dev_r5302_CNRS18_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4990 r5372 71 71 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 72 72 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 !MODIFICATION 74 PUBLIC mpp_lnk_2d_9 73 75 PUBLIC mppscatter, mppgather 74 76 PUBLIC mpp_ini_ice, mpp_ini_znl … … 77 79 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 78 80 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 81 82 type arrayptr 83 real , dimension (:,:), pointer :: pt2d 84 end type arrayptr 85 79 86 80 87 !! * Interfaces … … 511 518 END SUBROUTINE mpp_lnk_3d 512 519 520 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 521 !!---------------------------------------------------------------------- 522 !! *** routine mpp_lnk_2d_multiple *** 523 !! 524 !! ** Purpose : Message passing management for multiple 2d arrays 525 !! 526 !! ** Method : Use mppsend and mpprecv function for passing mask 527 !! between processors following neighboring subdomains. 528 !! domain parameters 529 !! nlci : first dimension of the local subdomain 530 !! nlcj : second dimension of the local subdomain 531 !! nbondi : mark for "east-west local boundary" 532 !! nbondj : mark for "north-south local boundary" 533 !! noea : number for local neighboring processors 534 !! nowe : number for local neighboring processors 535 !! noso : number for local neighboring processors 536 !! nono : number for local neighboring processors 537 !! 538 !!---------------------------------------------------------------------- 539 540 INTEGER :: num_fields 541 TYPE( arrayptr ) , DIMENSION(:) :: pt2d_array 542 !REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d_array ! Array of 2D arrays on which the boundary condition is applied 543 CHARACTER(len=1) , DIMENSION( : ), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 544 ! ! = T , U , V , F , W and I points 545 REAL(wp) , DIMENSION( : ), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 546 ! ! = 1. , the sign is kept 547 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 548 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 549 !! 550 INTEGER :: ji, jj, jl ! dummy loop indices 551 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 552 INTEGER :: imigr, iihom, ijhom ! temporary integers 553 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 554 555 REAL(wp) :: zland 556 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 557 ! 558 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 559 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 560 561 !!---------------------------------------------------------------------- 562 563 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 564 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 565 566 ! 567 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 568 ELSE ; zland = 0.e0 ! zero by default 569 ENDIF 570 571 ! 1. standard boundary treatment 572 ! ------------------------------ 573 ! 574 !First Array 575 DO ii = 1 , num_fields 576 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 577 ! 578 ! WARNING pt2d is defined only between nld and nle 579 DO jj = nlcj+1, jpj ! added line(s) (inner only) 580 581 582 pt2d_array(ii)%pt2d(nldi :nlei , jj ) = pt2d_array(ii)%pt2d(nldi:nlei, nlej ) 583 584 585 pt2d_array(ii)%pt2d(1 :nldi-1, jj ) = pt2d_array(ii)%pt2d(nldi , nlej ) 586 pt2d_array(ii)%pt2d(nlei+1:nlci , jj ) = pt2d_array(ii)%pt2d( nlei, nlej ) 587 END DO 588 DO ji = nlci+1, jpi ! added column(s) (full) 589 pt2d_array(ii)%pt2d( ji ,nldj :nlej ) = pt2d_array(ii)%pt2d( nlei , nldj:nlej) 590 pt2d_array(ii)%pt2d( ji ,1 :nldj-1 ) = pt2d_array(ii)%pt2d( nlei , nldj ) 591 pt2d_array(ii)%pt2d( ji ,nlej+1:jpj ) = pt2d_array(ii)%pt2d( nlei , nlej ) 592 END DO 593 ! 594 ELSE ! standard close or cyclic treatment 595 ! 596 ! ! East-West boundaries 597 IF( nbondi == 2 .AND. & ! Cyclic east-west 598 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 599 pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1 , : ) ! west 600 pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east 601 ELSE ! closed 602 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci , : ) = zland ! south except F-point 603 pt2d_array(ii)%pt2d( nlci-jpreci+1 : jpi , : ) = zland ! north 604 ENDIF 605 ! ! North-South boundaries (always closed) 606 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( : , 1 : jprecj ) = zland !south except F-point 607 pt2d_array(ii)%pt2d( : , nlcj-jprecj+1:jpj ) = zland ! north 608 ! 609 ENDIF 610 END DO 611 612 613 ! 2. East and west directions exchange 614 ! ------------------------------------ 615 ! we play with the neigbours AND the row number because of the periodicity 616 ! 617 DO ii = 1 , num_fields 618 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 619 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 620 iihom = nlci-nreci 621 DO jl = 1, jpreci 622 zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 623 zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 624 END DO 625 END SELECT 626 END DO 627 ! 628 ! ! Migrations 629 imigr = jpreci * jpj 630 ! 631 SELECT CASE ( nbondi ) 632 CASE ( -1 ) 633 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 634 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 635 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 636 CASE ( 0 ) 637 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 638 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 639 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 640 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 641 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 642 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 643 CASE ( 1 ) 644 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 645 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 646 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 647 END SELECT 648 ! 649 ! ! Write Dirichlet lateral conditions 650 iihom = nlci - jpreci 651 ! 652 653 DO ii = 1 , num_fields 654 SELECT CASE ( nbondi ) 655 CASE ( -1 ) 656 DO jl = 1, jpreci 657 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 658 END DO 659 CASE ( 0 ) 660 DO jl = 1, jpreci 661 pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 662 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 663 END DO 664 CASE ( 1 ) 665 DO jl = 1, jpreci 666 pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 667 END DO 668 END SELECT 669 END DO 670 671 ! 3. North and south directions 672 ! ----------------------------- 673 ! always closed : we play only with the neigbours 674 ! 675 !First Array 676 DO ii = 1 , num_fields 677 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 678 ijhom = nlcj-nrecj 679 DO jl = 1, jprecj 680 zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 681 zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 682 END DO 683 ENDIF 684 END DO 685 ! 686 ! ! Migrations 687 imigr = jprecj * jpi 688 ! 689 SELECT CASE ( nbondj ) 690 CASE ( -1 ) 691 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 692 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 693 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 694 CASE ( 0 ) 695 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 696 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 697 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 698 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 699 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 700 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 701 CASE ( 1 ) 702 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 703 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 704 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 705 END SELECT 706 ! 707 ! ! Write Dirichlet lateral conditions 708 ijhom = nlcj - jprecj 709 ! 710 711 DO ii = 1 , num_fields 712 !First Array 713 SELECT CASE ( nbondj ) 714 CASE ( -1 ) 715 DO jl = 1, jprecj 716 pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 717 END DO 718 CASE ( 0 ) 719 DO jl = 1, jprecj 720 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 721 pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 722 END DO 723 CASE ( 1 ) 724 DO jl = 1, jprecj 725 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 726 END DO 727 END SELECT 728 END DO 729 730 ! 4. north fold treatment 731 ! ----------------------- 732 ! 733 734 735 DO ii = 1 , num_fields 736 !First Array 737 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 738 ! 739 SELECT CASE ( jpni ) 740 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 741 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 742 END SELECT 743 ! 744 ENDIF 745 ! 746 END DO 747 748 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 749 ! 750 END SUBROUTINE mpp_lnk_2d_multiple 751 752 SUBROUTINE load_array(pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields) 753 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 754 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 755 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 756 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 757 CHARACTER(len=1) , DIMENSION( 9 ) :: type_array ! define the nature of ptab array grid-points 758 REAL(wp) , DIMENSION( 9 ) :: psgn_array ! =-1 the sign change across the north fold boundary 759 INTEGER , INTENT (inout):: num_fields 760 num_fields=num_fields+1 761 pt2d_array(num_fields)%pt2d=>pt2d 762 type_array(num_fields)=cd_type 763 psgn_array(num_fields)=psgn 764 END SUBROUTINE load_array 765 766 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB , psgnB, pt2dC, cd_typeC, psgnC, pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF, pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 767 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA ! Second 2D array on which the boundary condition is applied 768 REAL(wp), DIMENSION(jpi,jpj), TARGET , OPTIONAL , INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE ,pt2dF , pt2dG , pt2dH , pt2dI 769 CHARACTER(len=1) , INTENT(in ) :: cd_typeA ! define the nature of ptab array grid-points 770 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE , cd_typeF , cd_typeG , cd_typeH , cd_typeI 771 REAL(wp) , INTENT(in ) :: psgnA ! =-1 the sign change across the north fold boundary 772 REAL(wp) , OPTIONAL , INTENT(in ) :: psgnB , psgnC , psgnD , psgnE , psgnF , psgnG , psgnH , psgnI 773 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 774 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 775 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 776 CHARACTER(len=1) , DIMENSION( 9 ) :: type_array ! define the nature of ptab array grid-points 777 ! ! = T , U , V , F , W and I points 778 REAL(wp) , DIMENSION( 9 ) :: psgn_array ! =-1 the sign change across the north fold boundary 779 INTEGER :: num_fields 780 781 num_fields = 0 782 783 !! Load the first array 784 call load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields) 785 786 !! Look if more arrays are added 787 if(present (psgnB) )call load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 788 if(present (psgnC) )call load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 789 if(present (psgnD) )call load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 790 if(present (psgnE) )call load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 791 if(present (psgnF) )call load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 792 if(present (psgnG) )call load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 793 if(present (psgnH) )call load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 794 if(present (psgnI) )call load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 795 796 CALL mpp_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval) 797 END SUBROUTINE mpp_lnk_2d_9 798 513 799 514 800 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
Note: See TracChangeset
for help on using the changeset viewer.
