spmd_wiout.F File Reference

#include "implicit_f.inc"
#include "spmd.inc"
#include "com01_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	spmd_wiout (iout, iwiout)

Function/Subroutine Documentation

spmd_wiout()

subroutine spmd_wiout	(	integer	iout,
		integer	iwiout )

Definition at line 39 of file spmd_wiout.F.

C ecrit le buffer L01 sur p0
      USE message_mod 
      USE io_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
        USE spmd_comm_world_mod, ONLY : spmd_comm_world
#include      "implicit_f.inc"
C-----------------------------------------------------------------
C   M e s s a g e   P a s s i n g
C-----------------------------------------------
#include "spmd.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IOUT, IWIOUT
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
#ifdef MPI
      INTEGER MSGTYP,INFO,LOC_PROC,
     .        BUFSIZ,MSGOFF,SIZ,I,P,LEN,N,II,
     .        IOS,STATUS(MPI_STATUS_SIZE),IERROR,IBLANC,LNEW
      INTEGER, DIMENSION(:),ALLOCATABLE :: IWA
 
 
      INTEGER :: NINDX_PROC,SIZE_MESSAGE
            INTEGER, DIMENSION(NSPMD) :: IWIOUT_SPMD
            INTEGER, DIMENSION(NSPMD) :: PROC_RCV,DISPLACEMENT
      INTEGER :: INDX,REQ_S
      INTEGER, DIMENSION(NSPMD) :: REQ_R
 
      DATA msgoff/105/
      CHARACTER(LEN=NCHAROUT) :: LINE
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C IWIOUT est utilise pour connaitre le nb max de characteres a echanger
      ! MPI comm : every proc sends its IWIOUT_SAVE to the main proc
      iwiout_spmd(1:nspmd) = 0
      CALL mpi_gather( iwiout_save,1,mpi_integer,
     .                 iwiout_spmd,1,mpi_integer,
     .                 0,spmd_comm_world,ierror)
 
 
      loc_proc = ispmd + 1
      len = ncharout
      IF(ispmd/=0) ALLOCATE(iwa(iwiout+1))
!   ---------------------------------
!   Main proc : receives the message from other proc and writes the message in the *.out file
      IF(ispmd==0) THEN
        nindx_proc = 0
        size_message = 0
        !   ------------------
        displacement(1:nspmd) = 0
        DO p = 2, nspmd
            IF(iwiout_spmd(p)/=0) THEN
                nindx_proc = nindx_proc + 1 
                proc_rcv(nindx_proc) = p
                displacement(nindx_proc) = size_message
                size_message = size_message + iwiout_spmd(p) + 1
            ENDIF
        ENDDO
        ALLOCATE(iwa(size_message))
        !   ------------------
        DO i=1,nindx_proc
          p = proc_rcv(i)
          msgtyp = msgoff
          CALL mpi_irecv(iwa(1+displacement(i)),iwiout_spmd(p)+1,mpi_integer,it_spmd(p),
     .                  msgtyp,spmd_comm_world,req_r(i),ierror)
 
 
        ENDDO
        !   ------------------
        DO ii=1,nindx_proc
            CALL mpi_waitany(nindx_proc,req_r,indx,status,ierror)
            p = proc_rcv(indx)
            siz = iwiout_spmd(p)
            DO n = 1, siz, len
C   traitement special pour eliminer les blancs de fin de chaine
                i = len
                iblanc = ichar(' ')
                DO WHILE (iwa(displacement(indx)+n+i)==iblanc.AND.i>1)
                    i = i-1
                ENDDO
                lnew = i
C
                DO i = 1, lnew
                    line(i:i) = char(iwa(displacement(indx)+n+i))
                ENDDO
                WRITE(iout,fmt='(A)')line(1:lnew)
            ENDDO
        ENDDO
        !   ------------------
!   ---------------------------------
      ELSE
!   Secondary proc : sends the message to the main proc
C rewind fait ds check        REWIND(UNIT=IOUT)
        IF(iwiout_save>0) THEN
            ios = 0
            siz = 1
            !   ------------------
            DO WHILE(ios==0)
              READ(unit=iout,iostat=ios,fmt='(A)') line
              IF(ios==0) THEN
                DO i = 1, len
                  iwa(siz+i) = ichar(line(i:i))
                ENDDO
                siz = siz + len
              ENDIF
            ENDDO
            !   ------------------
            iwa(1) = siz-1
            rewind(unit=iout)
            WRITE(unit=iout,iostat=ios,fmt='(A)')
            msgtyp = msgoff
            CALL mpi_isend(iwa   ,siz           ,mpi_integer,it_spmd(1),
     .                    msgtyp,spmd_comm_world,req_s,ierror     )
 
            CALL mpi_wait(req_s,status,ierror)
            !   ------------------
        ENDIF
      ENDIF
!   ---------------------------------
      DEALLOCATE(iwa)
C
 
#endif
      RETURN