spmd_glob_minv.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	spmd_glob_minv (t_monvol, dt2, itypts, nelts, volmon, fr_mv)

Function/Subroutine Documentation

spmd_glob_minv()

subroutine spmd_glob_minv	(	type(monvol_struct_), dimension(nvolu)	t_monvol,
			dt2,
		integer	itypts,
		integer	nelts,
			volmon,
		integer, dimension(nspmd+2,nvolu)	fr_mv )

Definition at line 34 of file spmd_glob_minv.F.

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
        USE monvol_struct_mod
#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      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE(MONVOL_STRUCT_) :: T_MONVOL(NVOLU)
      INTEGER ITYPTS, NELTS, FR_MV(NSPMD+2,NVOLU)
      my_real
     .        dt2, volmon(*)
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
#ifdef MPI
      INTEGER I, IERROR, LOC_PROC, 
     . K1, KK1,
     .        LEN, myop
      my_real
     .        rbuf(3+nvolu*7), rrbuf(3+nvolu*7)
      INTEGER :: MY_TYPE
      INTEGER GLOB_MINV
      EXTERNAL glob_minv
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C
      loc_proc=ispmd+1
C
      rrbuf(1) = dt2
      rrbuf(2) = itypts
      rrbuf(3) = nelts
      DO i = 1, nvolu*7
        rrbuf(3+i) = zero
      END DO
      k1 = 1
      kk1 = 0
      DO i=1,nvolu
        IF(fr_mv(nspmd+2,i)==ispmd+1) THEN
          rrbuf(3+(i-1)*7+1)=volmon(kk1+1)
          rrbuf(3+(i-1)*7+2)=volmon(kk1+2)
          rrbuf(3+(i-1)*7+3)=volmon(kk1+5)
          rrbuf(3+(i-1)*7+4)=volmon(kk1+12)
          rrbuf(3+(i-1)*7+5)=volmon(kk1+16)
          rrbuf(3+(i-1)*7+6)=volmon(kk1+18)
          rrbuf(3+(i-1)*7+7)=volmon(kk1+21)
        END IF
        k1  = k1  + nimv
        kk1 = kk1 + nrvolu
      END DO
 
      len = 3+nvolu*7
 
      CALL mpi_type_contiguous(len,real,my_type,ierror)
      CALL mpi_type_commit(my_type,ierror)
      CALL mpi_op_create(glob_minv, .true., myop, ierror)
      
      CALL mpi_allreduce(rrbuf, rbuf, 1, my_type, myop,
     &                   spmd_comm_world, ierror)
     
      CALL mpi_op_free(myop, ierror)
      CALL mpi_type_free(my_type,ierror)
 
      dt2    = rbuf(1)
      itypts = rbuf(2)
      nelts  = rbuf(3)
      k1 = 1
      kk1 = 0
      DO i=1,nvolu
        volmon(kk1+1) =rbuf(3+(i-1)*7+1)
        volmon(kk1+2) =rbuf(3+(i-1)*7+2)
        volmon(kk1+5) =rbuf(3+(i-1)*7+3)
        volmon(kk1+12)=rbuf(3+(i-1)*7+4) ! pressure
        volmon(kk1+16)=rbuf(3+(i-1)*7+5) !Volume ?
        volmon(kk1+18)=rbuf(3+(i-1)*7+6) ! area
        volmon(kk1+21)=rbuf(3+(i-1)*7+7)
        t_monvol(i)%pressure = volmon(kk1+12)
        t_monvol(i)%temperature = volmon(kk1+13)
        t_monvol(i)%area = volmon(kk1+18)
!       write(6,*) "Pressure ", I, " is ", T_MONVOL(I)%pressure
!       write(6,*) "Temperature ", I, " is ", T_MONVOL(I)%temperature
!       write(6,*) "Area ", I, " is ", T_MONVOL(I)%area
!       write(6,*) "Volume ", I, " is ", VOLMON(KK1+16),T_MONVOL(I)%volume
        k1  = k1  + nimv
        kk1 = kk1 + nrvolu
      END DO
C
#endif
      RETURN