spmd_collect_multi_fvm.F File Reference

#include "implicit_f.inc"
#include "spmd.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "task_c.inc"
#include "spmd_c.inc"
#include "chara_c.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	spmd_collect_multi_fvm (ixs, multi_fvm, flag)

Function/Subroutine Documentation

spmd_collect_multi_fvm()

subroutine spmd_collect_multi_fvm	(	integer, dimension(nixs,*), intent(in)	ixs,
		type(multi_fvm_struct), intent(inout)	multi_fvm,
		integer, intent(in)	flag )

Definition at line 38 of file spmd_collect_multi_fvm.F.

!$COMMENT
!       SPMD_COLLECT_MULTI_FVM description
!       creation of a file with hexa values of MULTI_FVM%VEL
!       
!       SPMD_COLLECT_MULTI_FVM organization :
!        * gather of MULTI_FVM values on the main processor
!        * sorting of the value according the global user ID of the
!          element
!        * creation of the *.adb file
!
!$ENDCOMMENT
      USE checksum_mod, ONLY : double_array_checksum
      USE inoutfile_mod
      USE debug_mod
      USE multi_fvm_mod
      use element_mod , only : nixs
      USE spmd_comm_world_mod, ONLY : spmd_comm_world
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#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      "com04_c.inc"
#include      "task_c.inc"
#include      "spmd_c.inc"
#include      "chara_c.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, DIMENSION(NIXS,*), INTENT(in) :: IXS
      TYPE(MULTI_FVM_STRUCT), INTENT(INOUT) :: MULTI_FVM
      INTEGER,INTENT(in) :: FLAG ! 1: write the file ; 2 compute the checksum
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
      INTEGER MSGOFF,MSGOFF0,MSGTYP,I,K,N,
     .        FILEN 
      CHARACTER FILNAM*100,CYCLENUM*7
      INTEGER :: LEN_TMP_NAME,SHIFT
      CHARACTER(len=2148) :: TMP_NAME
      INTEGER, DIMENSION(NSPMD) :: SIZE_NUMELS
      INTEGER, DIMENSION(:), ALLOCATABLE :: SDNODG
      DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: AGLOB,RECGLOB 
      DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: RECGLOB_ORDERED
      ! array for sorting
      INTEGER, DIMENSION(:), ALLOCATABLE :: ITRI,WORK,INDEX_TRI
      INTEGER ::CHECKSUM
 
 
#ifdef MPI 
      INTEGER STATUS(MPI_STATUS_SIZE),IERROR
 
      DATA msgoff0/176/
      DATA msgoff/177/
#endif
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
      IF(ispmd==0) THEN
        ALLOCATE( sdnodg(numelsg) )
        ALLOCATE( recglob(4,numelsg) )
      ELSE
        ALLOCATE( sdnodg(numels) )
        ALLOCATE( recglob(0,0) )
        ALLOCATE( aglob(4,numels) )
      ENDIF
 
      size_numels(1:nspmd) = 0
#ifdef MPI 
      IF (ispmd/=0) THEN
 
      DO i = 1,numels
        aglob(1,i) = ixs(nixs,i)
        aglob(2,i) = multi_fvm%VEL(1,i)
        aglob(3,i) = multi_fvm%VEL(2,i)
        aglob(4,i) = multi_fvm%VEL(3,i)
      ENDDO
 
        msgtyp=msgoff0
        CALL mpi_send(numels,1,mpi_integer,
     .                it_spmd(1),msgtyp,
     .                spmd_comm_world,ierror)
 
        msgtyp=msgoff
        CALL mpi_send(aglob,4*numels,mpi_double_precision,
     .                it_spmd(1),msgtyp,
     .                spmd_comm_world,ierror)
      ELSE
        size_numels(1) = numels
        DO k=2,nspmd
            msgtyp=msgoff0
            CALL mpi_recv(size_numels(k),1,mpi_integer,
     .                    it_spmd(k),msgtyp,
     .                    spmd_comm_world,status,ierror)
 
            ALLOCATE( aglob(4,size_numels(k)) )
 
            msgtyp=msgoff
            CALL mpi_recv(aglob,4*size_numels(k),mpi_double_precision,
     .                    it_spmd(k),msgtyp,
     .                    spmd_comm_world,status,ierror)
    
            shift = 0
            DO i=1,k-1
                shift = shift + size_numels(i)
            ENDDO
            DO i=1,size_numels(k)
                recglob(1,i+shift) = aglob(1,i)
                recglob(2,i+shift) = aglob(2,i)
                recglob(3,i+shift) = aglob(3,i)
                recglob(4,i+shift) = aglob(4,i)
            ENDDO
            DEALLOCATE( aglob )
        END DO
      ENDIF
#endif
C
 
        IF(ispmd==0) THEN
 
            DO i=1,numels
                n =  ixs(nixs,i)
                recglob(1,i) = ixs(nixs,i)
                recglob(2,i) = multi_fvm%VEL(1,i)
                recglob(3,i) = multi_fvm%VEL(2,i)
                recglob(4,i) = multi_fvm%VEL(3,i)
            ENDDO
 
            ALLOCATE( itri(numelsg) )
            ALLOCATE( index_tri(2*numelsg) )  
            ALLOCATE( work(70000) )
            DO i=1,numelsg
                index_tri(i) = i
                itri(i) = nint(recglob(1,i))
            ENDDO
 
            CALL my_orders(0,work,itri,index_tri,numelsg,1)
 
            IF(flag == 2) THEN
              ALLOCATE(recglob_ordered(4,numelsg))
              DO i = 1, numelsg
                  n = index_tri(i)
                  recglob_ordered(1,i) = recglob(1,n)
                  recglob_ordered(2,i) = recglob(2,n)
                  recglob_ordered(3,i) = recglob(3,n)
                  recglob_ordered(4,i) = recglob(4,n)
              END DO
              checksum = double_array_checksum(recglob_ordered,numelsg,4)
              WRITE(iout,*) ncycle, "MULTI_FVM CHECKSUM:",checksum
              DEALLOCATE( recglob_ordered)
            ELSE IF(flag == 1) THEN
              WRITE(cyclenum,'(I7.7)')ncycle
              filnam=rootnam(1:rootlen)//'_FVM_'//chrun//'_'//cyclenum//'.adb'
  
              len_tmp_name = outfile_name_len + len_trim(filnam)
              tmp_name=outfile_name(1:outfile_name_len)//filnam(1:len_trim(filnam)) 
         
              OPEN(unit=idbg5,file=tmp_name(1:len_tmp_name),access='SEQUENTIAL',
     .                  form='FORMATTED',status='UNKNOWN')
 
              filen = rootlen+17
 
              DO i = 1, numelsg
                  n = index_tri(i)
                  WRITE(idbg5,'(A,I10,I10,Z20,Z20,Z20)' ) '>',ncycle,nint(recglob(1,n)),recglob(2,n),recglob(3,n),recglob(4,n)
              END DO
              WRITE (iout,1300)  filnam(1:filen)
              WRITE (istdo,1300) filnam(1:filen)
              CLOSE(unit=idbg5)
            ENDIF
 
            DEALLOCATE( itri )
            DEALLOCATE( index_tri )  
            DEALLOCATE( work )
 
      END IF
 
      IF(ALLOCATED(sdnodg)) DEALLOCATE( sdnodg )
      IF(ALLOCATED(recglob)) DEALLOCATE( recglob )
      IF(ALLOCATED(aglob)) DEALLOCATE( aglob )
C
 1300   FORMAT (4x,' DEBUG ANALYSIS FVM FILE :',1x,a,' WRITTEN')
      RETURN