Changeset 1579 for trunk/NEMO/OPA_SRC/lib_mpp.F90

Timestamp:

2009-08-05T12:14:11+02:00 (15 years ago)

Author:

smasson

Message:

avoid write in numout before definition of lwp, see ticket:237

File:

• trunk/NEMO/OPA_SRC/lib_mpp.F90 (modified) (7 diffs)

trunk/NEMO/OPA_SRC/lib_mpp.F90

@@ -165 +165 @@
 CONTAINS
 
-   FUNCTION mynode(localComm)
+   FUNCTION mynode(ldtxt, localComm)
       !!----------------------------------------------------------------------
       !!                  ***  routine mynode  ***
@@ -172 +172 @@
       !!
       !!----------------------------------------------------------------------
+      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
+      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
       INTEGER ::   mynode, ierr, code
       LOGICAL ::   mpi_was_called
-      INTEGER, OPTIONAL ::   localComm
+      
       NAMELIST/nam_mpp/ c_mpi_send, nn_buffer
       !!----------------------------------------------------------------------
       !
-      WRITE(numout,*)
-      WRITE(numout,*) 'mynode : mpi initialisation'
-      WRITE(numout,*) '~~~~~~ '
-      WRITE(numout,*)
+      WRITE(ldtxt(1),*)
+      WRITE(ldtxt(2),*) 'mynode : mpi initialisation'
+      WRITE(ldtxt(3),*) '~~~~~~ '
+      WRITE(ldtxt(4),*)
       !
       REWIND( numnam )               ! Namelist namrun : parameters of the run
       READ  ( numnam, nam_mpp )
       !                              ! control print
-      WRITE(numout,*) '        Namelist nam_mpp'
-      WRITE(numout,*) '           mpi send type            c_mpi_send = ', c_mpi_send
+      WRITE(ldtxt(5),*) '        Namelist nam_mpp'
+      WRITE(ldtxt(6),*) '           mpi send type            c_mpi_send = ', c_mpi_send
 
 #if defined key_agrif
@@ -196 +198 @@
          CALL mpi_initialized ( mpi_was_called, code )
          IF( code /= MPI_SUCCESS ) THEN
-            CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' )
+            WRITE(*, cform_err)
+            WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
             CALL mpi_abort( mpi_comm_world, code, ierr )
          ENDIF
@@ -204 +207 @@
             SELECT CASE ( c_mpi_send )
             CASE ( 'S' )                ! Standard mpi send (blocking)
-               WRITE(numout,*) '           Standard blocking mpi send (send)'
+               WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
             CASE ( 'B' )                ! Buffer mpi send (blocking)
-               WRITE(numout,*) '           Buffer blocking mpi send (bsend)'
+               WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
                CALL mpi_init_opa( ierr ) 
             CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
-               WRITE(numout,*) '           Immediate non-blocking send (isend)'
+               WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
                l_isend = .TRUE.
             CASE DEFAULT
-               WRITE(numout,cform_err)
-               WRITE(numout,*) '           bad value for c_mpi_send = ', c_mpi_send
+               WRITE(ldtxt(7),cform_err)
+               WRITE(ldtxt(8),*) '           bad value for c_mpi_send = ', c_mpi_send
                nstop = nstop + 1
             END SELECT
          ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
-            WRITE(numout,*) ' lib_mpp: You cannot provide a local communicator '
-            WRITE(numout,*) '          without calling MPI_Init before ! '
+            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 ( c_mpi_send )
             CASE ( 'S' )                ! Standard mpi send (blocking)
-               WRITE(numout,*) '           Standard blocking mpi send (send)'
+               WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
                CALL mpi_init( ierr )
             CASE ( 'B' )                ! Buffer mpi send (blocking)
-               WRITE(numout,*) '           Buffer blocking mpi send (bsend)'
+               WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
                CALL mpi_init_opa( ierr )
             CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
-               WRITE(numout,*) '           Immediate non-blocking send (isend)'
+               WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
                l_isend = .TRUE.
                CALL mpi_init( ierr )
             CASE DEFAULT
-               WRITE(ctmp1,*) '           bad value for c_mpi_send = ', c_mpi_send
-               CALL ctl_stop( ctmp1 )
+               WRITE(ldtxt(7),cform_err)
+               WRITE(ldtxt(8),*) '           bad value for c_mpi_send = ', c_mpi_send
+               nstop = nstop + 1
             END SELECT
 
@@ -240 +245 @@
             CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
             IF( code /= MPI_SUCCESS ) THEN
-               CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' )
+               WRITE(*, cform_err)
+               WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
                CALL mpi_abort( mpi_comm_world, code, ierr )
             ENDIF
@@ -250 +256 @@
          SELECT CASE ( c_mpi_send )
          CASE ( 'S' )                ! Standard mpi send (blocking)
-            WRITE(numout,*) '           Standard blocking mpi send (send)'
+            WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
          CASE ( 'B' )                ! Buffer mpi send (blocking)
-            WRITE(numout,*) '           Buffer blocking mpi send (bsend)'
+            WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
          CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
-            WRITE(numout,*) '           Immediate non-blocking send (isend)'
+            WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
             l_isend = .TRUE.
          CASE DEFAULT
-            WRITE(numout,cform_err)
-            WRITE(numout,*) '           bad value for c_mpi_send = ', c_mpi_send
+            WRITE(ldtxt(7),cform_err)
+            WRITE(ldtxt(8),*) '           bad value for c_mpi_send = ', c_mpi_send
             nstop = nstop + 1
          END SELECT
@@ -2291 +2297 @@
 CONTAINS
 
-   FUNCTION mynode( localComm ) RESULT (function_value)
-      INTEGER, OPTIONAL :: localComm
+   FUNCTION mynode( ldtxt, localComm ) RESULT (function_value)
+      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
+      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
       IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0
+      IF( .FALSE. )   ldtxt(:) = 'never done'
    END FUNCTION mynode