New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 4174 – NEMO

Changeset 4174


Ignore:
Timestamp:
2013-11-11T12:02:03+01:00 (11 years ago)
Author:
vichi
Message:

ticket #1173 step 2: Add in changes from the 2013/dev_r3948_CMCC_NorthFold_Opt

Location:
branches/2013/dev_CMCC_2013/NEMOGCM
Files:
5 edited
1 copied

Legend:

Unmodified
Added
Removed

  • branches/2013/dev_CMCC_2013/NEMOGCM/CONFIG/cfg.txt

    r3905 r4174  
    99ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC 
    1010ORCA2_LIM_PISCES OPA_SRC LIM_SRC_2 NST_SRC TOP_SRC 
     11GYRE_TEST OPA_SRC 

  • branches/2013/dev_CMCC_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r3768 r4174  
    283283   END SUBROUTINE lbc_lnk_3d 
    284284 
    285    SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 
    286       !!--------------------------------------------------------------------- 
    287       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    288       !! 
    289       !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    290       !!                to maintain the same interface with regards to the mpp case 
    291       !! 
    292       !!---------------------------------------------------------------------- 
    293       CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    294       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
    295       REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
    296       INTEGER                                                   ::   ib_bdy    ! BDY boundary set 
    297       !! 
    298       CALL lbc_lnk_3d( pt3d, cd_type, psgn) 
    299  
    300    END SUBROUTINE lbc_bdy_lnk_3d 
    301  
    302    SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 
    303       !!--------------------------------------------------------------------- 
    304       !!                  ***  ROUTINE lbc_bdy_lnk  *** 
    305       !! 
    306       !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    307       !!                to maintain the same interface with regards to the mpp case 
    308       !! 
    309       !!---------------------------------------------------------------------- 
    310       CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    311       REAL(wp), DIMENSION(jpi,jpj),     INTENT(inout)           ::   pt2d      ! 3D array on which the lbc is applied 
    312       REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
    313       INTEGER                                                   ::   ib_bdy    ! BDY boundary set 
    314       !! 
    315       CALL lbc_lnk_2d( pt2d, cd_type, psgn) 
    316  
    317    END SUBROUTINE lbc_bdy_lnk_2d 
    318  
    319285   SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    320286      !!--------------------------------------------------------------------- 
    … …  
    406372   END SUBROUTINE lbc_lnk_2d 
    407373 
     374#endif 
     375 
     376 
     377   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 
     378      !!--------------------------------------------------------------------- 
     379      !!                  ***  ROUTINE lbc_bdy_lnk  *** 
     380      !! 
     381      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
     382      !!                to maintain the same interface with regards to the mpp 
     383      !case 
     384      !! 
     385      !!---------------------------------------------------------------------- 
     386      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     387      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     388      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
     389      INTEGER                                                   ::   ib_bdy    ! BDY boundary set 
     390      !! 
     391      CALL lbc_lnk_3d( pt3d, cd_type, psgn) 
     392 
     393   END SUBROUTINE lbc_bdy_lnk_3d 
     394 
     395   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 
     396      !!--------------------------------------------------------------------- 
     397      !!                  ***  ROUTINE lbc_bdy_lnk  *** 
     398      !! 
     399      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
     400      !!                to maintain the same interface with regards to the mpp 
     401      !case 
     402      !! 
     403      !!---------------------------------------------------------------------- 
     404      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     405      REAL(wp), DIMENSION(jpi,jpj),     INTENT(inout)           ::   pt2d      ! 3D array on which the lbc is applied 
     406      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
     407      INTEGER                                                   ::   ib_bdy    ! BDY boundary set 
     408      !! 
     409      CALL lbc_lnk_2d( pt2d, cd_type, psgn) 
     410 
     411   END SUBROUTINE lbc_bdy_lnk_2d 
     412 
     413 
    408414   SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj ) 
    409415      !!--------------------------------------------------------------------- 
    … …  
    430436   END SUBROUTINE lbc_lnk_2d_e 
    431437 
    432 # endif 
    433438#endif 
    434439 

  • branches/2013/dev_CMCC_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r3294 r4174  
    55   !!====================================================================== 
    66   !! History :  3.2  ! 2009-03  (R. Benshila)  Original code  
     7   !!            3.5  ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization  
    78   !!---------------------------------------------------------------------- 
    89 
    … …  
    1112   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd) 
    1213   !!   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 
    1316   !!---------------------------------------------------------------------- 
    1417   USE dom_oce        ! ocean space and time domain  
    … …  
    2326 
    2427   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 
    2539 
    2640   !!---------------------------------------------------------------------- 
    … …  
    342356   END SUBROUTINE lbc_nfd_2d 
    343357 
    344    !!====================================================================== 
     358 
     359   SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 
     360      !!---------------------------------------------------------------------- 
     361      !!                  ***  routine mpp_lbc_nfd_3d  *** 
     362      !! 
     363      !! ** Purpose :   3D lateral boundary condition : North fold treatment 
     364      !!              without processor exchanges.  
     365      !! 
     366      !! ** Method  :    
     367      !! 
     368      !! ** Action  :   pt3d with updated values along the north fold 
     369      !!---------------------------------------------------------------------- 
     370      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
     371      !                                                        !   = T , U , V , F , W points 
     372      REAL(wp)                  , INTENT(in   ) ::   psgn      ! control of the sign change 
     373      !                                                        !   = -1. , the sign is changed if north fold boundary 
     374      !                                                        !   =  1. , the sign is kept  if north fold boundary 
     375      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3dl      ! 3D array on which the boundary condition is applied 
     376      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   pt3dr      ! 3D array on which the boundary condition is applied 
     377      ! 
     378      INTEGER  ::   ji, jk 
     379      INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
     380      !!---------------------------------------------------------------------- 
     381 
     382      SELECT CASE ( jpni ) 
     383      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
     384      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
     385      END SELECT 
     386      ijpjm1 = ijpj-1 
     387 
     388         ! 
     389         SELECT CASE ( npolj ) 
     390         ! 
     391         CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
     392            ! 
     393            SELECT CASE ( cd_type ) 
     394            CASE ( 'T' , 'W' )                         ! T-, W-point 
     395               IF (narea .ne. (jpnij - jpni + 1)) THEN 
     396                 startloop = 1 
     397               ELSE 
     398                 startloop = 2 
     399               ENDIF 
     400 
     401               DO jk = 1, jpk 
     402                  DO ji = startloop, nlci 
     403                     ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     404                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
     405                  END DO 
     406               END DO 
     407 
     408               IF(nimpp .ge. (jpiglo/2+1)) THEN 
     409                 startloop = 1 
     410               ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     411                 startloop = jpiglo/2+1 - nimpp + 1 
     412               ELSE 
     413                 startloop = nlci + 1 
     414               ENDIF 
     415               IF(startloop .le. nlci) THEN 
     416                 DO jk = 1, jpk 
     417                    DO ji = startloop, nlci 
     418                       ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     419                       jia = ji + nimpp - 1 
     420                       ijta = jpiglo - jia + 2 
     421                       IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 
     422                          pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 
     423                       ELSE 
     424                          pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
     425                       ENDIF 
     426                    END DO 
     427                 END DO 
     428               ENDIF 
     429 
     430 
     431 
     432            CASE ( 'U' )                               ! U-point 
     433               IF (narea .ne. (jpnij)) THEN 
     434                  endloop = nlci 
     435               ELSE 
     436                  endloop = nlci - 1 
     437               ENDIF 
     438               DO jk = 1, jpk 
     439                  DO ji = 1, endloop 
     440                     iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     441                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
     442                  END DO 
     443               END DO 
     444 
     445               IF (narea .ne. (jpnij)) THEN 
     446                  endloop = nlci 
     447               ELSE 
     448                  endloop = nlci - 1 
     449               ENDIF 
     450               IF(nimpp .ge. (jpiglo/2)) THEN 
     451                  startloop = 1 
     452               ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 
     453                  startloop = jpiglo/2 - nimpp + 1 
     454               ELSE 
     455                  startloop = endloop + 1 
     456               ENDIF 
     457               IF (startloop .le. endloop) THEN 
     458                 DO jk = 1, jpk 
     459                    DO ji = startloop, endloop 
     460                      iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     461                      jia = ji + nimpp - 1 
     462                      ijua = jpiglo - jia + 1 
     463                      IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 
     464                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 
     465                      ELSE 
     466                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
     467                      ENDIF 
     468                    END DO 
     469                 END DO 
     470               ENDIF 
     471 
     472            CASE ( 'V' )                               ! V-point 
     473               IF (narea .ne. (jpnij - jpni + 1)) THEN 
     474                  startloop = 1 
     475               ELSE 
     476                  startloop = 2 
     477               ENDIF 
     478               DO jk = 1, jpk 
     479                  DO ji = startloop, nlci 
     480                     ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     481                     pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
     482                     pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 
     483                  END DO 
     484               END DO 
     485            CASE ( 'F' )                               ! F-point 
     486               IF (narea .ne. (jpnij)) THEN 
     487                  endloop = nlci 
     488               ELSE 
     489                  endloop = nlci - 1 
     490               ENDIF 
     491               DO jk = 1, jpk 
     492                  DO ji = 1, endloop 
     493                     iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     494                     pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
     495                     pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 
     496                  END DO 
     497               END DO 
     498            END SELECT 
     499            ! 
     500 
     501         CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
     502            ! 
     503            SELECT CASE ( cd_type ) 
     504            CASE ( 'T' , 'W' )                         ! T-, W-point 
     505               DO jk = 1, jpk 
     506                  DO ji = 1, nlci 
     507                     ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     508                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 
     509                  END DO 
     510               END DO 
     511 
     512            CASE ( 'U' )                               ! U-point 
     513               IF (narea .ne. (jpnij)) THEN 
     514                  endloop = nlci 
     515               ELSE 
     516                  endloop = nlci - 1 
     517               ENDIF 
     518               DO jk = 1, jpk 
     519                  DO ji = 1, endloop 
     520                     iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     521                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 
     522                  END DO 
     523               END DO 
     524 
     525            CASE ( 'V' )                               ! V-point 
     526               DO jk = 1, jpk 
     527                  DO ji = 1, nlci 
     528                     ijt = jpiglo - ji- nimpp - nimppt(isendto(1)) + 3 
     529                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 
     530                  END DO 
     531               END DO 
     532 
     533               IF(nimpp .ge. (jpiglo/2+1)) THEN 
     534                  startloop = 1 
     535               ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     536                  startloop = jpiglo/2+1 - nimpp + 1 
     537               ELSE 
     538                  startloop = nlci + 1 
     539               ENDIF 
     540               IF(startloop .le. nlci) THEN 
     541                 DO jk = 1, jpk 
     542                    DO ji = startloop, nlci 
     543                       ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     544                       pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 
     545                    END DO 
     546                 END DO 
     547               ENDIF 
     548 
     549            CASE ( 'F' )                               ! F-point 
     550               IF (narea .ne. (jpnij)) THEN 
     551                  endloop = nlci 
     552               ELSE 
     553                  endloop = nlci - 1 
     554               ENDIF 
     555               DO jk = 1, jpk 
     556                  DO ji = 1, endloop 
     557                     iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     558                     pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 
     559                  END DO 
     560               END DO 
     561 
     562               IF (narea .ne. (jpnij)) THEN 
     563                  endloop = nlci 
     564               ELSE 
     565                  endloop = nlci - 1 
     566               ENDIF 
     567               IF(nimpp .ge. (jpiglo/2+1)) THEN 
     568                  startloop = 1 
     569               ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     570                  startloop = jpiglo/2+1 - nimpp + 1 
     571               ELSE 
     572                  startloop = endloop + 1 
     573               ENDIF 
     574               IF (startloop .le. endloop) THEN 
     575                  DO jk = 1, jpk 
     576                     DO ji = startloop, endloop 
     577                        iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     578                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 
     579                     END DO 
     580                  END DO 
     581               ENDIF 
     582 
     583            END SELECT 
     584 
     585         CASE DEFAULT                           ! *  closed : the code probably never go through 
     586            ! 
     587            SELECT CASE ( cd_type) 
     588            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
     589               pt3dl(:, 1  ,jk) = 0.e0 
     590               pt3dl(:,ijpj,jk) = 0.e0 
     591            CASE ( 'F' )                               ! F-point 
     592               pt3dl(:,ijpj,jk) = 0.e0 
     593            END SELECT 
     594            ! 
     595         END SELECT     !  npolj 
     596         ! 
     597      ! 
     598   END SUBROUTINE mpp_lbc_nfd_3d 
     599 
     600 
     601   SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 
     602      !!---------------------------------------------------------------------- 
     603      !!                  ***  routine mpp_lbc_nfd_2d  *** 
     604      !! 
     605      !! ** Purpose :   2D lateral boundary condition : North fold treatment 
     606      !!       without processor exchanges.  
     607      !! 
     608      !! ** Method  :    
     609      !! 
     610      !! ** Action  :   pt2d with updated values along the north fold 
     611      !!---------------------------------------------------------------------- 
     612      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points 
     613      !                                                      ! = T , U , V , F , W points 
     614      REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change 
     615      !                                                      !   = -1. , the sign is changed if north fold boundary 
     616      !                                                      !   =  1. , the sign is kept  if north fold boundary 
     617      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2dl      ! 2D array on which the boundary condition is applied 
     618      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pt2dr      ! 2D array on which the boundary condition is applied 
     619      ! 
     620      INTEGER  ::   ji 
     621      INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
     622      !!---------------------------------------------------------------------- 
     623 
     624      SELECT CASE ( jpni ) 
     625      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
     626      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
     627      END SELECT 
     628      ! 
     629      ijpjm1 = ijpj-1 
     630 
     631 
     632      SELECT CASE ( npolj ) 
     633      ! 
     634      CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
     635         ! 
     636         SELECT CASE ( cd_type ) 
     637         ! 
     638         CASE ( 'T' , 'W' )                               ! T- , W-points 
     639            IF (narea .ne. (jpnij - jpni + 1)) THEN 
     640              startloop = 1 
     641            ELSE 
     642              startloop = 2 
     643            ENDIF 
     644            DO ji = startloop, nlci 
     645              ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     646              pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
     647            END DO 
     648 
     649            IF(nimpp .ge. (jpiglo/2+1)) THEN 
     650               startloop = 1 
     651            ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     652               startloop = jpiglo/2+1 - nimpp + 1 
     653            ELSE 
     654               startloop = nlci + 1 
     655            ENDIF 
     656            DO ji = startloop, nlci 
     657               ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     658               jia = ji + nimpp - 1 
     659               ijta = jpiglo - jia + 2 
     660               IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 
     661                  pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 
     662               ELSE 
     663                  pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
     664               ENDIF 
     665            END DO 
     666 
     667         CASE ( 'U' )                                     ! U-point 
     668            IF (narea .ne. (jpnij)) THEN 
     669               endloop = nlci 
     670            ELSE 
     671               endloop = nlci - 1 
     672            ENDIF 
     673            DO ji = 1, endloop 
     674               iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     675               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
     676            END DO 
     677 
     678            IF (narea .ne. (jpnij)) THEN 
     679               endloop = nlci 
     680            ELSE 
     681               endloop = nlci - 1 
     682            ENDIF 
     683            IF(nimpp .ge. (jpiglo/2)) THEN 
     684               startloop = 1 
     685            ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 
     686               startloop = jpiglo/2 - nimpp + 1 
     687            ELSE 
     688               startloop = endloop + 1 
     689            ENDIF 
     690            DO ji = startloop, endloop 
     691               iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     692               jia = ji + nimpp - 1 
     693               ijua = jpiglo - jia + 1 
     694               IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 
     695                  pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 
     696               ELSE 
     697                  pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
     698               ENDIF 
     699            END DO 
     700 
     701         CASE ( 'V' )                                     ! V-point 
     702            IF (narea .ne. (jpnij - jpni + 1)) THEN 
     703              startloop = 1 
     704            ELSE 
     705              startloop = 2 
     706            ENDIF 
     707            DO ji = startloop, nlci 
     708              ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     709              pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 
     710              pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 
     711            END DO 
     712 
     713         CASE ( 'F' )                                     ! F-point 
     714            IF (narea .ne. (jpnij)) THEN 
     715               endloop = nlci 
     716            ELSE 
     717               endloop = nlci - 1 
     718            ENDIF 
     719            DO ji = 1, endloop 
     720               iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     721               pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 
     722               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 
     723            END DO 
     724 
     725         CASE ( 'I' )                                     ! ice U-V point (I-point) 
     726            IF (narea .ne. (jpnij - jpni + 1)) THEN 
     727               startloop = 1 
     728            ELSE 
     729               startloop = 3 
     730               pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
     731            ENDIF 
     732            DO ji = startloop, nlci 
     733               iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 
     734               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
     735            END DO 
     736 
     737         CASE ( 'J' )                                     ! first ice U-V point 
     738            IF (narea .ne. (jpnij - jpni + 1)) THEN 
     739               startloop = 1 
     740            ELSE 
     741               startloop = 3 
     742               pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
     743            ENDIF 
     744            DO ji = startloop, nlci 
     745               iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 
     746               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
     747            END DO 
     748 
     749         CASE ( 'K' )                                     ! second ice U-V point 
     750            IF (narea .ne. (jpnij - jpni + 1)) THEN 
     751               startloop = 1 
     752            ELSE 
     753               startloop = 3 
     754               pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
     755            ENDIF 
     756            DO ji = startloop, nlci 
     757               iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 
     758               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
     759            END DO 
     760 
     761         END SELECT 
     762         ! 
     763      CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
     764         ! 
     765         SELECT CASE ( cd_type ) 
     766         CASE ( 'T' , 'W' )                               ! T-, W-point 
     767            DO ji = 1, nlci 
     768               ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     769               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 
     770            END DO 
     771 
     772         CASE ( 'U' )                                     ! U-point 
     773            IF (narea .ne. (jpnij)) THEN 
     774               endloop = nlci 
     775            ELSE 
     776               endloop = nlci - 1 
     777            ENDIF 
     778            DO ji = 1, endloop 
     779               iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     780               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 
     781            END DO 
     782 
     783         CASE ( 'V' )                                     ! V-point 
     784            DO ji = 1, nlci 
     785               ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     786               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 
     787            END DO 
     788            IF(nimpp .ge. (jpiglo/2+1)) THEN 
     789               startloop = 1 
     790            ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     791               startloop = jpiglo/2+1 - nimpp + 1 
     792            ELSE 
     793               startloop = nlci + 1 
     794            ENDIF 
     795            DO ji = startloop, nlci 
     796               ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 
     797               pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 
     798            END DO 
     799 
     800         CASE ( 'F' )                               ! F-point 
     801            IF (narea .ne. (jpnij)) THEN 
     802               endloop = nlci 
     803            ELSE 
     804               endloop = nlci - 1 
     805            ENDIF 
     806            DO ji = 1, endloop 
     807               iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     808               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 
     809            END DO 
     810 
     811            IF (narea .ne. (jpnij)) THEN 
     812               endloop = nlci 
     813            ELSE 
     814               endloop = nlci - 1 
     815            ENDIF 
     816            IF(nimpp .ge. (jpiglo/2+1)) THEN 
     817               startloop = 1 
     818            ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 
     819               startloop = jpiglo/2+1 - nimpp + 1 
     820            ELSE 
     821               startloop = endloop + 1 
     822            ENDIF 
     823 
     824            DO ji = startloop, endloop 
     825               iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 
     826               pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 
     827            END DO 
     828 
     829         CASE ( 'I' )                                  ! ice U-V point (I-point) 
     830               IF (narea .ne. (jpnij - jpni + 1)) THEN 
     831                  startloop = 1 
     832               ELSE 
     833                  startloop = 2 
     834               ENDIF 
     835               IF (narea .ne. jpnij) THEN 
     836                  endloop = nlci 
     837               ELSE 
     838                  endloop = nlci - 1 
     839               ENDIF 
     840               DO ji = startloop , endloop 
     841                  ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     842                  pt2dl(ji,ijpj)= 0.5 * (pt2dr(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
     843               END DO 
     844 
     845         CASE ( 'J' )                                  ! first ice U-V point 
     846               IF (narea .ne. (jpnij - jpni + 1)) THEN 
     847                  startloop = 1 
     848               ELSE 
     849                  startloop = 2 
     850               ENDIF 
     851               IF (narea .ne. jpnij) THEN 
     852                  endloop = nlci 
     853               ELSE 
     854                  endloop = nlci - 1 
     855               ENDIF 
     856               DO ji = startloop , endloop 
     857                  ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     858                  pt2dl(ji,ijpj) = pt2dr(ji,ijpjm1) 
     859               END DO 
     860 
     861         CASE ( 'K' )                                  ! second ice U-V point 
     862               IF (narea .ne. (jpnij - jpni + 1)) THEN 
     863                  startloop = 1 
     864               ELSE 
     865                  startloop = 2 
     866               ENDIF 
     867               IF (narea .ne. jpnij) THEN 
     868                  endloop = nlci 
     869               ELSE 
     870                  endloop = nlci - 1 
     871               ENDIF 
     872               DO ji = startloop, endloop 
     873                  ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 
     874                  pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 
     875               END DO 
     876 
     877         END SELECT 
     878         ! 
     879      CASE DEFAULT                           ! *  closed : the code probably never go through 
     880         ! 
     881         SELECT CASE ( cd_type) 
     882         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
     883            pt2dl(:, 1     ) = 0.e0 
     884            pt2dl(:,ijpj) = 0.e0 
     885         CASE ( 'F' )                                   ! F-point 
     886            pt2dl(:,ijpj) = 0.e0 
     887         CASE ( 'I' )                                   ! ice U-V point 
     888            pt2dl(:, 1     ) = 0.e0 
     889            pt2dl(:,ijpj) = 0.e0 
     890         CASE ( 'J' )                                   ! first ice U-V point 
     891            pt2dl(:, 1     ) = 0.e0 
     892            pt2dl(:,ijpj) = 0.e0 
     893         CASE ( 'K' )                                   ! second ice U-V point 
     894            pt2dl(:, 1     ) = 0.e0 
     895            pt2dl(:,ijpj) = 0.e0 
     896         END SELECT 
     897         ! 
     898      END SELECT 
     899      ! 
     900   END SUBROUTINE mpp_lbc_nfd_2d 
     901 
    345902END MODULE lbcnfd 

  • branches/2013/dev_CMCC_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r3918 r4174  
    2222   !!                          'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 
    2323   !!                          the mppobc routine to optimize the BDY and OBC communications 
     24   !!            3.5  !  2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 
    2425   !!---------------------------------------------------------------------- 
    2526 
    … …  
    165166   REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE   ::   xnorthgloio 
    166167   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   foldwk      ! Workspace for message transfers avoiding mpi_allgather 
     168   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   ztabl_3d 
     169   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   ztabr_3d 
    167170 
    168171   ! Arrays used in mpp_lbc_north_2d() 
    … …  
    170173   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   xnorthgloio_2d 
    171174   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   foldwk_2d    ! Workspace for message transfers avoiding mpi_allgather 
     175   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE   ::   ztabl_2d 
     176   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE   ::   ztabr_2d 
    172177 
    173178   ! Arrays used in mpp_lbc_north_e() 
    … …  
    175180   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   xnorthgloio_e 
    176181 
    177    ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public 
    178    INTEGER, PUBLIC,  PARAMETER :: jpmaxngh = 8                 ! Assumed maximum number of active neighbours 
    179    INTEGER, PUBLIC,  PARAMETER :: jptyps   = 5                 ! Number of different neighbour lists to be used for northfold exchanges 
    180    INTEGER, PUBLIC,  DIMENSION (jpmaxngh,jptyps)    ::   isendto 
    181    INTEGER, PUBLIC,  DIMENSION (jptyps)             ::   nsndto 
    182182   LOGICAL, PUBLIC                                  ::   ln_nnogather     = .FALSE.  ! namelist control of northfold comms 
    183183   LOGICAL, PUBLIC                                  ::   l_north_nogather = .FALSE.  ! internal control of northfold comms 
    … …  
    214214         ! 
    215215         &      tab_e(jpiglo,4+2*jpr2dj) , xnorthloc_e(jpi,4+2*jpr2dj) , xnorthgloio_e(jpi,4+2*jpr2dj,jpni) ,   & 
     216         ! 
     217         &      ztabl_3d(jpi,4,jpk), ztabr_3d(jpi*jpmaxngh, 4, jpk), ztabl_2d(jpi,4), ztabr_2d(jpi*jpmaxngh, 4), & 
    216218         ! 
    217219         &      STAT=lib_mpp_alloc ) 
    … …  
    25852587      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    25862588      !                                                              !   = T ,  U , V , F or W  gridpoints 
    2587       REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold 
     2589      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    25882590      !!                                                             ! =  1. , the sign is kept 
    2589       INTEGER ::   ji, jj, jr 
     2591      INTEGER ::   ji, jj, jr, jk 
    25902592      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    25912593      INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2592       INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather 
     2594      INTEGER, DIMENSION (jpmaxngh)           ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    25932595      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    25942596      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2595       !!---------------------------------------------------------------------- 
    2596       ! 
     2597      INTEGER :: istatus(mpi_status_size) 
     2598      INTEGER :: iflag 
     2599      !!---------------------------------------------------------------------- 
     2600      ! 
     2601 
    25972602      ijpj   = 4 
    2598       ityp = -1 
    25992603      ijpjm1 = 3 
    2600       tab_3d(:,:,:) = 0.e0 
    2601       ! 
    2602       DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d 
    2603          ij = jj - nlcj + ijpj 
    2604          xnorthloc(:,ij,:) = pt3d(:,jj,:) 
     2604      ! 
     2605      DO jk = 1, jpk 
     2606         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d 
     2607            ij = jj - nlcj + ijpj 
     2608            xnorthloc(:,ij,jk) = pt3d(:,jj,jk) 
     2609         END DO 
    26052610      END DO 
    26062611      ! 
    26072612      !                                     ! Build in procs of ncomm_north the xnorthgloio 
    26082613      itaille = jpi * jpk * ijpj 
     2614 
     2615 
    26092616      IF ( l_north_nogather ) THEN 
    26102617         ! 
    2611          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 
     2618         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    26122619         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    26132620         ! 
    2614          DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    2615             ij = jj - nlcj + ijpj 
    2616             DO ji = 1, nlci 
    2617                tab_3d(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 
    2618             END DO 
    2619          END DO 
    2620  
    2621          ! 
    2622          ! Set the exchange type in order to access the correct list of active neighbours 
    2623          ! 
    2624          SELECT CASE ( cd_type ) 
    2625             CASE ( 'T' , 'W' ) 
    2626                ityp = 1 
    2627             CASE ( 'U' ) 
    2628                ityp = 2 
    2629             CASE ( 'V' ) 
    2630                ityp = 3 
    2631             CASE ( 'F' ) 
    2632                ityp = 4 
    2633             CASE ( 'I' ) 
    2634                ityp = 5 
    2635             CASE DEFAULT 
    2636                ityp = -1                    ! Set a default value for unsupported types which 
    2637                                             ! will cause a fallback to the mpi_allgather method 
    2638          END SELECT 
    2639          IF ( ityp .gt. 0 ) THEN 
    2640  
    2641             DO jr = 1,nsndto(ityp) 
    2642                CALL mppsend(5, xnorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 
    2643             END DO 
    2644             DO jr = 1,nsndto(ityp) 
    2645                CALL mpprecv(5, foldwk, itaille, isendto(jr,ityp)) 
    2646                iproc = isendto(jr,ityp) + 1 
    2647                ildi = nldit (iproc) 
    2648                ilei = nleit (iproc) 
    2649                iilb = nimppt(iproc) 
    2650                DO jj = 1, ijpj 
    2651                   DO ji = ildi, ilei 
    2652                      tab_3d(ji+iilb-1,jj,:) = foldwk(ji,jj,:) 
    2653                   END DO 
     2621 
     2622         ztabr_3d(:,:,:) = 0 
     2623 
     2624         DO jk = 1, jpk 
     2625            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2626               ij = jj - nlcj + ijpj 
     2627               DO ji = 1, nlci 
     2628                  ztabl_3d(ji,ij,jk) = pt3d(ji,jj,jk) 
    26542629               END DO 
    26552630            END DO 
    2656             IF (l_isend) THEN 
    2657                DO jr = 1,nsndto(ityp) 
    2658                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2631         END DO 
     2632 
     2633         DO jr = 1,nsndto 
     2634            IF (isendto(jr) .ne. narea) CALL mppsend(5, xnorthloc, itaille, isendto(jr)-1, ml_req_nf(jr)) 
     2635         END DO 
     2636         DO jr = 1,nsndto 
     2637            iproc = isendto(jr) 
     2638            ildi = nldit (iproc) 
     2639            ilei = nleit (iproc) 
     2640            iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 
     2641            IF(isendto(jr) .ne. narea) THEN 
     2642              CALL mpprecv(5, foldwk, itaille, isendto(jr)-1) 
     2643              DO jk = 1, jpk 
     2644                 DO jj = 1, ijpj 
     2645                    DO ji = 1, ilei 
     2646                       ztabr_3d(iilb+ji,jj,jk) = foldwk(ji,jj,jk) 
     2647                    END DO 
     2648                 END DO 
     2649              END DO 
     2650           ELSE 
     2651              DO jk = 1, jpk 
     2652                 DO jj = 1, ijpj 
     2653                    DO ji = 1, ilei 
     2654                       ztabr_3d(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 
     2655                    END DO 
     2656                 END DO 
     2657              END DO 
     2658           ENDIF 
     2659         END DO 
     2660         IF (l_isend) THEN 
     2661            DO jr = 1,nsndto 
     2662               IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2663            END DO 
     2664         ENDIF 
     2665         CALL mpp_lbc_nfd( ztabl_3d, ztabr_3d, cd_type, psgn )   ! North fold boundary condition 
     2666         ! 
     2667         DO jk=1, jpk 
     2668            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
     2669               ij = jj - nlcj + ijpj 
     2670               DO ji= 1, nlci 
     2671                  pt3d(ji,jj,jk) = ztabl_3d(ji,ij,jk) 
    26592672               END DO 
    2660             ENDIF 
    2661  
    2662          ENDIF 
    2663  
    2664       ENDIF 
    2665  
    2666       IF ( ityp .lt. 0 ) THEN 
     2673            END DO 
     2674         END DO 
     2675         ! 
     2676 
     2677      ELSE 
    26672678         CALL MPI_ALLGATHER( xnorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    26682679            &                xnorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    … …  
    26732684            ilei  = nleit (iproc) 
    26742685            iilb  = nimppt(iproc) 
    2675             DO jj = 1, ijpj 
    2676                DO ji = ildi, ilei 
    2677                   tab_3d(ji+iilb-1,jj,:) = xnorthgloio(ji,jj,:,jr) 
     2686            DO jk=1, jpk 
     2687               DO jj = 1, ijpj 
     2688                  DO ji = ildi, ilei 
     2689                     tab_3d(ji+iilb-1,jj,jk) = xnorthgloio(ji,jj,jk,jr) 
     2690                  END DO 
    26782691               END DO 
    26792692            END DO 
    26802693         END DO 
    2681       ENDIF 
    2682       ! 
    2683       ! The tab_3d array has been either: 
    2684       !  a. Fully populated by the mpi_allgather operation or 
    2685       !  b. Had the active points for this domain and northern neighbours populated 
    2686       !     by peer to peer exchanges 
    2687       ! Either way the array may be folded by lbc_nfd and the result for the span of 
    2688       ! this domain will be identical. 
    2689       ! 
    2690       CALL lbc_nfd( tab_3d, cd_type, psgn )   ! North fold boundary condition 
    2691       ! 
    2692       DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
    2693          ij = jj - nlcj + ijpj 
    2694          DO ji= 1, nlci 
    2695             pt3d(ji,jj,:) = tab_3d(ji+nimpp-1,ij,:) 
    2696          END DO 
    2697       END DO 
    2698       ! 
     2694         CALL lbc_nfd( tab_3d, cd_type, psgn )   ! North fold boundary condition 
     2695         ! 
     2696         DO jk=1, jpk 
     2697            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d 
     2698               ij = jj - nlcj + ijpj 
     2699               DO ji= 1, nlci 
     2700                  pt3d(ji,jj,jk) = tab_3d(ji+nimpp-1,ij,jk) 
     2701               END DO 
     2702            END DO 
     2703         END DO 
     2704         ! 
     2705      ENDIF 
     2706 
    26992707   END SUBROUTINE mpp_lbc_north_3d 
    27002708 
    … …  
    27142722      !! 
    27152723      !!---------------------------------------------------------------------- 
    2716       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the b.c. is applied 
    2717       CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
     2724      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied 
     2725      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
    27182726      !                                                          !   = T ,  U , V , F or W  gridpoints 
    2719       REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold 
     2727      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
    27202728      !!                                                             ! =  1. , the sign is kept 
    27212729      INTEGER ::   ji, jj, jr 
    27222730      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    27232731      INTEGER ::   ijpj, ijpjm1, ij, iproc 
    2724       INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather 
     2732      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
    27252733      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
    27262734      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
    2727       !!---------------------------------------------------------------------- 
    2728       ! 
     2735      INTEGER :: istatus(mpi_status_size) 
     2736      INTEGER :: iflag 
     2737      !!---------------------------------------------------------------------- 
     2738      ! 
     2739 
    27292740      ijpj   = 4 
    2730       ityp = -1 
    27312741      ijpjm1 = 3 
    2732       tab_2d(:,:) = 0.e0 
    27332742      ! 
    27342743      DO jj = nlcj-ijpj+1, nlcj             ! put in xnorthloc_2d the last 4 jlines of pt2d 
    … …  
    27412750      IF ( l_north_nogather ) THEN 
    27422751         ! 
    2743          ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 
     2752         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
    27442753         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
    27452754         ! 
     2755 
     2756         ztabr_2d(:,:) = 0 
     2757 
    27462758         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
    27472759            ij = jj - nlcj + ijpj 
    27482760            DO ji = 1, nlci 
    2749                tab_2d(ji+nimpp-1,ij) = pt2d(ji,jj) 
     2761               ztabl_2d(ji,ij) = pt2d(ji,jj) 
    27502762            END DO 
    27512763         END DO 
    27522764 
    2753          ! 
    2754          ! Set the exchange type in order to access the correct list of active neighbours 
    2755          ! 
    2756          SELECT CASE ( cd_type ) 
    2757             CASE ( 'T' , 'W' ) 
    2758                ityp = 1 
    2759             CASE ( 'U' ) 
    2760                ityp = 2 
    2761             CASE ( 'V' ) 
    2762                ityp = 3 
    2763             CASE ( 'F' ) 
    2764                ityp = 4 
    2765             CASE ( 'I' ) 
    2766                ityp = 5 
    2767             CASE DEFAULT 
    2768                ityp = -1                    ! Set a default value for unsupported types which 
    2769                                             ! will cause a fallback to the mpi_allgather method 
    2770          END SELECT 
    2771  
    2772          IF ( ityp .gt. 0 ) THEN 
    2773  
    2774             DO jr = 1,nsndto(ityp) 
    2775                CALL mppsend(5, xnorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 
     2765         DO jr = 1,nsndto 
     2766            IF (isendto(jr) .ne. narea) CALL mppsend(5, xnorthloc_2d, itaille, isendto(jr)-1, ml_req_nf(jr)) 
     2767         END DO 
     2768         DO jr = 1,nsndto 
     2769            iproc = isendto(jr) 
     2770            ildi = nldit (iproc) 
     2771            ilei = nleit (iproc) 
     2772            iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 
     2773            IF(isendto(jr) .ne. narea) THEN 
     2774              CALL mpprecv(5, foldwk_2d, itaille, isendto(jr)-1) 
     2775              DO jj = 1, ijpj 
     2776                 DO ji = 1, ilei 
     2777                    ztabr_2d(iilb+ji,jj) = foldwk_2d(ji,jj) 
     2778                 END DO 
     2779              END DO 
     2780            ELSE 
     2781              DO jj = 1, ijpj 
     2782                 DO ji = 1, ilei 
     2783                    ztabr_2d(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 
     2784                 END DO 
     2785              END DO 
     2786            ENDIF 
     2787         END DO 
     2788         IF (l_isend) THEN 
     2789            DO jr = 1,nsndto 
     2790               IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    27762791            END DO 
    2777             DO jr = 1,nsndto(ityp) 
    2778                CALL mpprecv(5, foldwk_2d, itaille, isendto(jr,ityp)) 
    2779                iproc = isendto(jr,ityp) + 1 
    2780                ildi = nldit (iproc) 
    2781                ilei = nleit (iproc) 
    2782                iilb = nimppt(iproc) 
    2783                DO jj = 1, ijpj 
    2784                   DO ji = ildi, ilei 
    2785                      tab_2d(ji+iilb-1,jj) = foldwk_2d(ji,jj) 
    2786                   END DO 
    2787                END DO 
     2792         ENDIF 
     2793         CALL mpp_lbc_nfd( ztabl_2d, ztabr_2d, cd_type, psgn )   ! North fold boundary condition 
     2794         ! 
     2795         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2796            ij = jj - nlcj + ijpj 
     2797            DO ji = 1, nlci 
     2798               pt2d(ji,jj) = ztabl_2d(ji,ij) 
    27882799            END DO 
    2789             IF (l_isend) THEN 
    2790                DO jr = 1,nsndto(ityp) 
    2791                   CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
    2792                END DO 
    2793             ENDIF 
    2794  
    2795          ENDIF 
    2796  
    2797       ENDIF 
    2798  
    2799       IF ( ityp .lt. 0 ) THEN 
     2800         END DO 
     2801         ! 
     2802 
     2803      ELSE 
    28002804         CALL MPI_ALLGATHER( xnorthloc_2d  , itaille, MPI_DOUBLE_PRECISION,        & 
    28012805            &                xnorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    … …  
    28122816            END DO 
    28132817         END DO 
    2814       ENDIF 
    2815       ! 
    2816       ! The tab array has been either: 
    2817       !  a. Fully populated by the mpi_allgather operation or 
    2818       !  b. Had the active points for this domain and northern neighbours populated 
    2819       !     by peer to peer exchanges 
    2820       ! Either way the array may be folded by lbc_nfd and the result for the span of 
    2821       ! this domain will be identical. 
    2822       ! 
    2823       CALL lbc_nfd( tab_2d, cd_type, psgn )   ! North fold boundary condition 
    2824       ! 
    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) = tab_2d(ji+nimpp-1,ij) 
    2830          END DO 
    2831       END DO 
    2832       ! 
     2818         CALL lbc_nfd( tab_2d, cd_type, psgn )   ! North fold boundary condition 
     2819         ! 
     2820         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2821            ij = jj - nlcj + ijpj 
     2822            DO ji = 1, nlci 
     2823               pt2d(ji,jj) = tab_2d(ji+nimpp-1,ij) 
     2824            END DO 
     2825         END DO 
     2826         ! 
     2827      ENDIF 
    28332828   END SUBROUTINE mpp_lbc_north_2d 
    28342829 
    … …  
    28602855      ! 
    28612856      ijpj=4 
    2862       tab_e(:,:) = 0.e0 
    28632857 
    28642858      ij=0 

  • branches/2013/dev_CMCC_2013/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r3769 r4174  
    8484#endif 
    8585   USE sbctide, ONLY: lk_tide 
     86   USE lbcnfd, ONLY: isendto, nsndto ! Setup of north fold exchanges  
    8687 
    8788   IMPLICIT NONE 
    … …  
    683684      !!====================================================================== 
    684685      !!                     ***  ROUTINE  nemo_northcomms  *** 
    685       !! nemo_northcomms    :  Setup for north fold exchanges with explicit peer to peer messaging 
     686      !! nemo_northcomms    :  Setup for north fold exchanges with explicit  
     687      !!                       point-to-point messaging 
    686688      !!===================================================================== 
    687689      !!---------------------------------------------------------------------- 
    … …  
    690692      !!---------------------------------------------------------------------- 
    691693      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE) 
    692       !!---------------------------------------------------------------------- 
    693  
    694       INTEGER ::   ji, jj, jk, ij, jtyp    ! dummy loop indices 
    695       INTEGER ::   ijpj                    ! number of rows involved in north-fold exchange 
    696       INTEGER ::   northcomms_alloc        ! allocate return status 
    697       REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) ::   znnbrs     ! workspace 
    698       LOGICAL,  ALLOCATABLE, DIMENSION ( : )   ::   lrankset   ! workspace 
    699  
    700       IF(lwp) WRITE(numout,*) 
    701       IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists' 
    702       IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
    703  
    704       !!---------------------------------------------------------------------- 
    705       ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc ) 
    706       ALLOCATE( lrankset(jpnij), stat = northcomms_alloc ) 
    707       IF( northcomms_alloc /= 0 ) THEN 
    708          WRITE(numout,cform_war) 
    709          WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays' 
    710          CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' ) 
    711       ENDIF 
     694      !!    2.0  ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)  
     695      !!---------------------------------------------------------------------- 
     696 
     697      INTEGER  ::   sxM, dxM, sxT, dxT, jn 
     698      INTEGER  ::   njmppmax 
     699 
     700      njmppmax = MAXVAL( njmppt ) 
     701     
     702      !initializes the north-fold communication variables 
     703      isendto(:) = 0 
    712704      nsndto = 0 
    713       isendto = -1 
    714       ijpj   = 4 
    715       ! 
    716       ! This routine has been called because ln_nnogather has been set true ( nammpp ) 
    717       ! However, these first few exchanges have to use the mpi_allgather method to 
    718       ! establish the neighbour lists to use in subsequent peer to peer exchanges. 
    719       ! Consequently, set l_north_nogather to be false here and set it true only after 
    720       ! the lists have been established. 
    721       ! 
    722       l_north_nogather = .FALSE. 
    723       ! 
    724       ! Exchange and store ranks on northern rows 
    725  
    726       DO jtyp = 1,4 
    727  
    728          lrankset = .FALSE. 
    729          znnbrs = narea 
    730          SELECT CASE (jtyp) 
    731             CASE(1) 
    732                CALL lbc_lnk( znnbrs, 'T', 1. )      ! Type 1: T,W-points 
    733             CASE(2) 
    734                CALL lbc_lnk( znnbrs, 'U', 1. )      ! Type 2: U-point 
    735             CASE(3) 
    736                CALL lbc_lnk( znnbrs, 'V', 1. )      ! Type 3: V-point 
    737             CASE(4) 
    738                CALL lbc_lnk( znnbrs, 'F', 1. )      ! Type 4: F-point 
    739          END SELECT 
    740  
    741          IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN 
    742             DO jj = nlcj-ijpj+1, nlcj 
    743                ij = jj - nlcj + ijpj 
    744                DO ji = 1,jpi 
    745                   IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 
    746                &     lrankset(INT(znnbrs(ji,jj))) = .true. 
    747                END DO 
    748             END DO 
    749  
    750             DO jj = 1,jpnij 
    751                IF ( lrankset(jj) ) THEN 
    752                   nsndto(jtyp) = nsndto(jtyp) + 1 
    753                   IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN 
    754                      CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 
    755                   &                 ' jpmaxngh will need to be increased ') 
    756                   ENDIF 
    757                   isendto(nsndto(jtyp),jtyp) = jj-1   ! narea converted to MPI rank 
    758                ENDIF 
    759             END DO 
    760          ENDIF 
    761  
    762       END DO 
    763  
    764       ! 
    765       ! Type 5: I-point 
    766       ! 
    767       ! ICE point exchanges may involve some averaging. The neighbours list is 
    768       ! built up using two exchanges to ensure that the whole stencil is covered. 
    769       ! lrankset should not be reset between these 'J' and 'K' point exchanges 
    770  
    771       jtyp = 5 
    772       lrankset = .FALSE. 
    773       znnbrs = narea 
    774       CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point 
    775  
    776       IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN 
    777          DO jj = nlcj-ijpj+1, nlcj 
    778             ij = jj - nlcj + ijpj 
    779             DO ji = 1,jpi 
    780                IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 
    781             &     lrankset(INT(znnbrs(ji,jj))) = .true. 
    782          END DO 
    783         END DO 
    784       ENDIF 
    785  
    786       znnbrs = narea 
    787       CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point 
    788  
    789       IF ( njmppt(narea) .EQ. MAXVAL( njmppt )) THEN 
    790          DO jj = nlcj-ijpj+1, nlcj 
    791             ij = jj - nlcj + ijpj 
    792             DO ji = 1,jpi 
    793                IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND.  INT(znnbrs(ji,jj)) .NE. narea ) & 
    794             &       lrankset( INT(znnbrs(ji,jj))) = .true. 
    795             END DO 
    796          END DO 
    797  
    798          DO jj = 1,jpnij 
    799             IF ( lrankset(jj) ) THEN 
    800                nsndto(jtyp) = nsndto(jtyp) + 1 
    801                IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN 
    802                   CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 
    803                &                 ' jpmaxngh will need to be increased ') 
    804                ENDIF 
    805                isendto(nsndto(jtyp),jtyp) = jj-1   ! narea converted to MPI rank 
    806             ENDIF 
    807          END DO 
    808          ! 
    809          ! For northern row areas, set l_north_nogather so that all subsequent exchanges 
    810          ! can use peer to peer communications at the north fold 
    811          ! 
    812          l_north_nogather = .TRUE. 
    813          ! 
    814       ENDIF 
    815       DEALLOCATE( znnbrs ) 
    816       DEALLOCATE( lrankset ) 
    817  
     705 
     706      !if I am a process in the north 
     707      IF ( njmpp == njmppmax ) THEN 
     708          !sxM is the first point (in the global domain) needed to compute the 
     709          !north-fold for the current process 
     710          sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1 
     711          !dxM is the last point (in the global domain) needed to compute the 
     712          !north-fold for the current process 
     713          dxM = jpiglo - nimppt(narea) + 2 
     714 
     715          !loop over the other north-fold processes to find the processes 
     716          !managing the points belonging to the sxT-dxT range 
     717          DO jn = jpnij - jpni +1, jpnij 
     718             IF ( njmppt(jn) == njmppmax ) THEN 
     719                !sxT is the first point (in the global domain) of the jn 
     720                !process 
     721                sxT = nimppt(jn) 
     722                !dxT is the last point (in the global domain) of the jn 
     723                !process 
     724                dxT = nimppt(jn) + nlcit(jn) - 1 
     725                IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN 
     726                   nsndto = nsndto + 1 
     727                   isendto(nsndto) = jn 
     728                ELSEIF ((sxM .le. sxT) .AND. (dxM .gt. dxT)) THEN 
     729                   nsndto = nsndto + 1 
     730                   isendto(nsndto) = jn 
     731                ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN 
     732                   nsndto = nsndto + 1 
     733                   isendto(nsndto) = jn 
     734                END IF 
     735             END IF 
     736          END DO 
     737      ENDIF 
     738      l_north_nogather = .TRUE. 
    818739   END SUBROUTINE nemo_northcomms 
    819740#else 
Note: See TracChangeset for help on using the changeset viewer.