spmd_tri17box.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	spmd_tri17box (nelems, nmes, x, v, frots, ks, bminmal, weight, nin, isendto, ircvfrom, nmesr, ixs, ixs16, eminxs)

Function/Subroutine Documentation

spmd_tri17box()

subroutine spmd_tri17box	(	integer, dimension(*)	nelems,
		integer	nmes,
			x,
			v,
			frots,
			ks,
			bminmal,
		integer, dimension(*)	weight,
		integer	nin,
		integer, dimension(ninter+1,*)	isendto,
		integer, dimension(ninter+1,*)	ircvfrom,
		integer	nmesr,
		integer, dimension(nixs,*)	ixs,
		integer, dimension(8,*)	ixs16,
			eminxs )

Definition at line 37 of file spmd_tri17box.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE tri7box
      USE message_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      "com04_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NELEMS(*), WEIGHT(*), IXS(NIXS,*), IXS16(8,*),
     .        ISENDTO(NINTER+1,*), IRCVFROM(NINTER+1,*),
     .        NMES, NMESR, NIN
      my_real
     .        bminmal(6),
     .        x(3,*), v(3,*), frots(7,*), ks(2,*), eminxs(6,*)
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
#ifdef MPI
      INTEGER MSGTYP,INFO,I,NOD, LOC_PROC,P,IDEB,
     .        SIZ,J, L, BUFSIZ, LEN, NB, N1, NE,
     .        STATUS(MPI_STATUS_SIZE),IERROR,REQ_SB(NSPMD),
     .        REQ_RB(NSPMD),KK,NBIRECV,IRINDEXI(NSPMD),
     .        REQ_RD(NSPMD),REQ_SD(NSPMD),REQ_SD2(NSPMD),
     .        INDEXI,ISINDEXI(NSPMD),INDEX(NMES),NBOX(NSPMD),
     .        MSGOFF, MSGOFF2, MSGOFF3
      DATA msgoff/129/
      DATA msgoff2/130/
      DATA msgoff3/131/
 
      my_real bminma(6,nspmd)
      TYPE(real_pointer), DIMENSION(NSPMD) :: BUF
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
      loc_proc = ispmd + 1
C
C   boite minmax pour le tri provenant de i7buce BMINMA
C
      IF(ircvfrom(nin,loc_proc)==0.AND.
     .   isendto(nin,loc_proc)==0) RETURN
      bminma(1,loc_proc) = bminmal(1)
      bminma(2,loc_proc) = bminmal(2)
      bminma(3,loc_proc) = bminmal(3)
      bminma(4,loc_proc) = bminmal(4)
      bminma(5,loc_proc) = bminmal(5)
      bminma(6,loc_proc) = bminmal(6)
C
C   envoi boite
C
      IF(ircvfrom(nin,loc_proc)/=0) THEN
        DO p = 1, nspmd
          IF(isendto(nin,p)/=0) THEN
            IF(p/=loc_proc) THEN
              msgtyp = msgoff
              CALL mpi_isend(
     .          bminma(1,loc_proc),6        ,real  ,it_spmd(p),msgtyp,
     .          spmd_comm_world    ,req_sb(p),ierror)
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C   reception des boites min-max
C
      IF(isendto(nin,loc_proc)/=0) THEN
        nbirecv=0
        DO p = 1, nspmd
          IF(ircvfrom(nin,p)/=0) THEN
            IF(loc_proc/=p) THEN
              msgtyp = msgoff
              nbirecv=nbirecv+1
              irindexi(nbirecv)=p
              CALL mpi_irecv(
     .          bminma(1,p)   ,6              ,real  ,it_spmd(p),msgtyp,
     .          spmd_comm_world,req_rb(nbirecv),ierror)
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C   envoi de XREM
C
      siz = 112
      IF(isendto(nin,loc_proc)/=0) THEN
        DO kk = 1, nbirecv
          CALL mpi_waitany(nbirecv,req_rb,indexi,status,ierror)
          p=irindexi(indexi)
C
          nb = 0
          DO i=1,nmes
            IF(eminxs(4,i)>bminma(1,p).AND.
     .         eminxs(5,i)>bminma(2,p).AND.
     .         eminxs(6,i)>bminma(3,p).AND.
     .         eminxs(1,i)<bminma(4,p).AND.
     .         eminxs(2,i)<bminma(5,p).AND.
     .         eminxs(3,i)<bminma(6,p))THEN
              nb = nb + 1
              index(nb) = i
            ENDIF
          ENDDO
          nbox(p) = nb
C
C Envoi taille msg
C
          msgtyp = msgoff2
          CALL mpi_isend(nbox(p),1,mpi_integer,it_spmd(p),msgtyp,
     .                 spmd_comm_world,req_sd(p),ierror)
C
C Alloc buffer
C
          IF (nb>0) THEN
            ALLOCATE(buf(p)%P(siz*nb),stat=ierror)
            IF(ierror/=0) THEN
              CALL ancmsg(msgid=20,anmode=aninfo)
              CALL arret(2)
            ENDIF
            l = 0
            DO j = 1, nb
              i = index(j)
              buf(p)%p(l+1) = eminxs(1,i)
              buf(p)%p(l+2) = eminxs(2,i)
              buf(p)%p(l+3) = eminxs(3,i)
              buf(p)%p(l+4) = eminxs(4,i)
              buf(p)%p(l+5) = eminxs(5,i)
              buf(p)%p(l+6) = eminxs(6,i)
              buf(p)%p(l+7) = i
              ne = nelems(i)
C
              n1 = ixs(2,ne)
              buf(p)%p(l+8)  = x(1,n1)
              buf(p)%p(l+9)  = x(2,n1)
              buf(p)%p(l+10) = x(3,n1)
              buf(p)%p(l+11) = v(1,n1)
              buf(p)%p(l+12) = v(2,n1)
              buf(p)%p(l+13) = v(3,n1)
              n1 = ixs(3,ne)
              buf(p)%p(l+14) = x(1,n1)
              buf(p)%p(l+15) = x(2,n1)
              buf(p)%p(l+16) = x(3,n1)
              buf(p)%p(l+17) = v(1,n1)
              buf(p)%p(l+18) = v(2,n1)
              buf(p)%p(l+19) = v(3,n1)
              n1 = ixs(4,ne)
              buf(p)%p(l+20) = x(1,n1)
              buf(p)%p(l+21) = x(2,n1)
              buf(p)%p(l+22) = x(3,n1)
              buf(p)%p(l+23) = v(1,n1)
              buf(p)%p(l+24) = v(2,n1)
              buf(p)%p(l+25) = v(3,n1)
              n1 = ixs(5,ne)
              buf(p)%p(l+26) = x(1,n1)
              buf(p)%p(l+27) = x(2,n1)
              buf(p)%p(l+28) = x(3,n1)
              buf(p)%p(l+29) = v(1,n1)
              buf(p)%p(l+30) = v(2,n1)
              buf(p)%p(l+31) = v(3,n1)
              n1 = ixs(6,ne)
              buf(p)%p(l+32) = x(1,n1)
              buf(p)%p(l+33) = x(2,n1)
              buf(p)%p(l+34) = x(3,n1)
              buf(p)%p(l+35) = v(1,n1)
              buf(p)%p(l+36) = v(2,n1)
              buf(p)%p(l+37) = v(3,n1)
              n1 = ixs(7,ne)
              buf(p)%p(l+38) = x(1,n1)
              buf(p)%p(l+39) = x(2,n1)
              buf(p)%p(l+40) = x(3,n1)
              buf(p)%p(l+41) = v(1,n1)
              buf(p)%p(l+42) = v(2,n1)
              buf(p)%p(l+43) = v(3,n1)
              n1 = ixs(8,ne)
              buf(p)%p(l+44) = x(1,n1)
              buf(p)%p(l+45) = x(2,n1)
              buf(p)%p(l+46) = x(3,n1)
              buf(p)%p(l+47) = v(1,n1)
              buf(p)%p(l+48) = v(2,n1)
              buf(p)%p(l+49) = v(3,n1)
              n1 = ixs(9,ne)
              buf(p)%p(l+50) = x(1,n1)
              buf(p)%p(l+51) = x(2,n1)
              buf(p)%p(l+52) = x(3,n1)
              buf(p)%p(l+53) = v(1,n1)
              buf(p)%p(l+54) = v(2,n1)
              buf(p)%p(l+55) = v(3,n1)
C
              n1 = ixs16(1,ne-numels8-numels10-numels20)
              buf(p)%p(l+56)  = x(1,n1)
              buf(p)%p(l+57)  = x(2,n1)
              buf(p)%p(l+58) = x(3,n1)
              buf(p)%p(l+59) = v(1,n1)
              buf(p)%p(l+60) = v(2,n1)
              buf(p)%p(l+61) = v(3,n1)
              n1 = ixs16(2,ne-numels8-numels10-numels20)
              buf(p)%p(l+62) = x(1,n1)
              buf(p)%p(l+63) = x(2,n1)
              buf(p)%p(l+64) = x(3,n1)
              buf(p)%p(l+65) = v(1,n1)
              buf(p)%p(l+66) = v(2,n1)
              buf(p)%p(l+67) = v(3,n1)
              n1 = ixs16(3,ne-numels8-numels10-numels20)
              buf(p)%p(l+68) = x(1,n1)
              buf(p)%p(l+69) = x(2,n1)
              buf(p)%p(l+70) = x(3,n1)
              buf(p)%p(l+71) = v(1,n1)
              buf(p)%p(l+72) = v(2,n1)
              buf(p)%p(l+73) = v(3,n1)
              n1 = ixs16(4,ne-numels8-numels10-numels20)
              buf(p)%p(l+74) = x(1,n1)
              buf(p)%p(l+75) = x(2,n1)
              buf(p)%p(l+76) = x(3,n1)
              buf(p)%p(l+77) = v(1,n1)
              buf(p)%p(l+78) = v(2,n1)
              buf(p)%p(l+79) = v(3,n1)
              n1 = ixs16(5,ne-numels8-numels10-numels20)
              buf(p)%p(l+80) = x(1,n1)
              buf(p)%p(l+81) = x(2,n1)
              buf(p)%p(l+82) = x(3,n1)
              buf(p)%p(l+83) = v(1,n1)
              buf(p)%p(l+84) = v(2,n1)
              buf(p)%p(l+85) = v(3,n1)
              n1 = ixs16(6,ne-numels8-numels10-numels20)
              buf(p)%p(l+86) = x(1,n1)
              buf(p)%p(l+87) = x(2,n1)
              buf(p)%p(l+88) = x(3,n1)
              buf(p)%p(l+89) = v(1,n1)
              buf(p)%p(l+90) = v(2,n1)
              buf(p)%p(l+91) = v(3,n1)
              n1 = ixs16(7,ne-numels8-numels10-numels20)
              buf(p)%p(l+92) = x(1,n1)
              buf(p)%p(l+93) = x(2,n1)
              buf(p)%p(l+94) = x(3,n1)
              buf(p)%p(l+95) = v(1,n1)
              buf(p)%p(l+96) = v(2,n1)
              buf(p)%p(l+97) = v(3,n1)
              n1 = ixs16(8,ne-numels8-numels10-numels20)
              buf(p)%p(l+98) = x(1,n1)
              buf(p)%p(l+99) = x(2,n1)
              buf(p)%p(l+100) = x(3,n1)
              buf(p)%p(l+101) = v(1,n1)
              buf(p)%p(l+102) = v(2,n1)
              buf(p)%p(l+103) = v(3,n1)
 
C
              buf(p)%p(l+104) = frots(1,i)
              buf(p)%p(l+105) = frots(2,i)
              buf(p)%p(l+106) = frots(3,i)
              buf(p)%p(l+107) = frots(4,i)
              buf(p)%p(l+108) = frots(5,i)
              buf(p)%p(l+109) = frots(6,i)
              buf(p)%p(l+110) = frots(7,i)
C
              buf(p)%p(l+111) = ks(1,i)
              buf(p)%p(l+112) = ks(2,i)
C
              l = l + siz
            END DO
C
            msgtyp = msgoff3
            CALL mpi_isend(
     1        buf(p)%P(1),l,real,it_spmd(p),msgtyp,
     2        spmd_comm_world,req_sd2(p),ierror)
          ENDIF
        ENDDO
      ENDIF
C
C   reception  des donnees XREM
C
      IF(ircvfrom(nin,loc_proc)/=0) THEN
        nmesr = 0
        l=0
        DO p = 1, nspmd
          nsnfi(nin)%P(p) = 0
          IF(isendto(nin,p)/=0) THEN
            IF(loc_proc/=p) THEN
              msgtyp = msgoff2
              CALL mpi_recv(nsnfi(nin)%P(p),1,mpi_integer,it_spmd(p),
     .                      msgtyp,spmd_comm_world,status,ierror)
              IF(nsnfi(nin)%P(p)>0) THEN
                l=l+1
                isindexi(l)=p
                nmesr = nmesr + nsnfi(nin)%P(p)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
        nbirecv=l
C
C Allocate total size
C
        IF(nmesr>0) THEN
          ALLOCATE(xrem(siz,nmesr),stat=ierror)
          IF(ierror/=0) THEN
            CALL ancmsg(msgid=20,anmode=aninfo)
            CALL arret(2)
          ENDIF
          ideb = 1
          DO l = 1, nbirecv
            p = isindexi(l)
            len = nsnfi(nin)%P(p)*siz
            msgtyp = msgoff3
            CALL mpi_irecv(
     1        xrem(1,ideb),len,real,it_spmd(p),
     2        msgtyp,spmd_comm_world,req_rd(l),ierror)
            ideb = ideb + nsnfi(nin)%P(p)
          ENDDO
          DO l = 1, nbirecv
            CALL mpi_waitany(nbirecv,req_rd,indexi,status,ierror)
C           P=ISINDEXI(INDEXI)
          ENDDO
        ENDIF
      ENDIF
C
      IF(ircvfrom(nin,loc_proc)/=0) THEN
        DO p = 1, nspmd
          IF(isendto(nin,p)/=0) THEN
            IF(p/=loc_proc) THEN
              CALL mpi_wait(req_sb(p),status,ierror)
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
      IF(isendto(nin,loc_proc)/=0) THEN
        DO p = 1, nspmd
          IF(ircvfrom(nin,p)/=0) THEN
            IF(p/=loc_proc) THEN
              CALL mpi_wait(req_sd(p),status,ierror)
              IF(nbox(p)/=0) THEN
                CALL mpi_wait(req_sd2(p),status,ierror)
                DEALLOCATE(buf(p)%p)
              END IF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
#endif
      RETURN