Changeset 1804 for branches/dev_005_AWL/NEMO/OPA_SRC/lib_mpp.F90

Timestamp:

2010-02-08T11:51:02+01:00 (14 years ago)

Author:

sga

Message:

merge of trunk changes from r1782 to r1802 into NEMO branch dev_005_AWL

File:

• branches/dev_005_AWL/NEMO/OPA_SRC/lib_mpp.F90 (modified) (4 diffs)

branches/dev_005_AWL/NEMO/OPA_SRC/lib_mpp.F90

@@ -112 +112 @@
    INTEGER ::   mppsize        ! number of process
    INTEGER ::   mpprank        ! process number  [ 0 - size-1 ]
-   INTEGER ::   mpi_comm_opa   ! opa local communicator
+!$AGRIF_DO_NOT_TREAT
+   INTEGER, PUBLIC ::   mpi_comm_opa   ! opa local communicator
+!$AGRIF_END_DO_NOT_TREAT
 
    ! variables used in case of sea-ice
@@ -191 +193 @@
       WRITE(ldtxt(6),*) '      size in bytes of exported buffer   nn_buffer   = ', nn_buffer
 
-#if defined key_agrif
-      IF( Agrif_Root() ) THEN
-#endif
-         !!bug RB : should be clean to use Agrif in coupled mode
-#if ! defined key_agrif
-         CALL mpi_initialized ( mpi_was_called, code )
-         IF( code /= MPI_SUCCESS ) THEN
-            WRITE(*, cform_err)
-            WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
-            CALL mpi_abort( mpi_comm_world, code, ierr )
-         ENDIF
-
-         IF( PRESENT(localComm) .and. mpi_was_called ) THEN
-            mpi_comm_opa = localComm
-            SELECT CASE ( cn_mpi_send )
-            CASE ( 'S' )                ! Standard mpi send (blocking)
-               WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
-            CASE ( 'B' )                ! Buffer mpi send (blocking)
-               WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
-               CALL mpi_init_opa( ierr ) 
-            CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
-               WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
-               l_isend = .TRUE.
-            CASE DEFAULT
-               WRITE(ldtxt(7),cform_err)
-               WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send
-               nstop = nstop + 1
-            END SELECT
-         ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
-            WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator '
-            WRITE(ldtxt(8),*) '          without calling MPI_Init before ! '
-            nstop = nstop + 1
-         ELSE
-#endif
-            SELECT CASE ( cn_mpi_send )
-            CASE ( 'S' )                ! Standard mpi send (blocking)
-               WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
-               CALL mpi_init( ierr )
-            CASE ( 'B' )                ! Buffer mpi send (blocking)
-               WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
-               CALL mpi_init_opa( ierr )
-            CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
-               WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
-               l_isend = .TRUE.
-               CALL mpi_init( ierr )
-            CASE DEFAULT
-               WRITE(ldtxt(7),cform_err)
-               WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send
-               nstop = nstop + 1
-            END SELECT
-
-#if ! defined key_agrif
-            CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
-            IF( code /= MPI_SUCCESS ) THEN
-               WRITE(*, cform_err)
-               WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
-               CALL mpi_abort( mpi_comm_world, code, ierr )
-            ENDIF
-            !
-         ENDIF
-#endif
-#if defined key_agrif
-      ELSE
+      CALL mpi_initialized ( mpi_was_called, code )
+      IF( code /= MPI_SUCCESS ) THEN
+         WRITE(*, cform_err)
+         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
+         CALL mpi_abort( mpi_comm_world, code, ierr )
+      ENDIF
+
+      IF( mpi_was_called ) THEN
+         !
          SELECT CASE ( cn_mpi_send )
          CASE ( 'S' )                ! Standard mpi send (blocking)
@@ -259 +207 @@
          CASE ( 'B' )                ! Buffer mpi send (blocking)
             WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
+            CALL mpi_init_opa( ierr ) 
          CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
             WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
@@ -267 +216 @@
             nstop = nstop + 1
          END SELECT
+      ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
+         WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator '
+         WRITE(ldtxt(8),*) '          without calling MPI_Init before ! '
+         nstop = nstop + 1
+      ELSE
+         SELECT CASE ( cn_mpi_send )
+         CASE ( 'S' )                ! Standard mpi send (blocking)
+            WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
+            CALL mpi_init( ierr )
+         CASE ( 'B' )                ! Buffer mpi send (blocking)
+            WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
+            CALL mpi_init_opa( ierr )
+         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
+            WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
+            l_isend = .TRUE.
+            CALL mpi_init( ierr )
+         CASE DEFAULT
+            WRITE(ldtxt(7),cform_err)
+            WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send
+            nstop = nstop + 1
+         END SELECT
+         !
       ENDIF
 
-      mpi_comm_opa = mpi_comm_world
-#endif
+      IF( PRESENT(localComm) ) THEN 
+         IF( Agrif_Root() ) THEN
+            mpi_comm_opa = localComm
+         ENDIF
+      ELSE
+         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
+         IF( code /= MPI_SUCCESS ) THEN
+            WRITE(*, cform_err)
+            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
+            CALL mpi_abort( mpi_comm_world, code, ierr )
+         ENDIF
+      ENDIF 
+
       CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
       CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )