dxyzsph.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	dxyzsph (nesph, kxsp, x, spbuf, snnsphg, nnsph)

Function/Subroutine Documentation

dxyzsph()

subroutine dxyzsph	(	integer	nesph,
		integer, dimension(nisp,*)	kxsp,
			x,
			spbuf,
		integer	snnsphg,
		integer	nnsph )

Definition at line 31 of file dxyzsph.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "sphcom.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NESPH, KXSP(NISP,*),SNNSPHG,NNSPH
      my_real
     .  x(3,*),spbuf(nspbuf,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N, J, INOD,CNT,BUF
      my_real
     3   xi,yi,zi,r,
     4   xq(3),fact
      REAL R4,R4NP(3*NNSPH)
C-----------------------------------------------
      IF (numsph+maxpjet==0) GOTO 100
C-----------------------------------------------
      cnt = 0
      fact =(three/(four*sqrt(two)))**third
      DO 200 n=1,numsph+maxpjet
         inod=kxsp(3,n)
         xi  =x(1,inod)
         yi  =x(2,inod)
         zi  =x(3,inod)
           r   = spbuf(1,n)*fact
           xq(1) =xi+r
           xq(2) =yi-r
           xq(3) =zi-r
C           XQ(1) =XI+R*SQRT(2.)
C           XQ(2) =YI+R*SQRT(2.)/SQRT(3.)
C           XQ(3) =ZI-R/SQRT(3.)
           IF (nspmd == 1) THEN
            DO j=1,3
             r4 = xq(j)
             CALL write_r_c(r4,1)
            ENDDO
           ELSE
             cnt = cnt + 1
             r4np(cnt) = xq(1)
             cnt = cnt + 1
             r4np(cnt) = xq(2)
             cnt = cnt + 1
             r4np(cnt) = xq(3)
           ENDIF
           xq(1) =xi-r
           xq(2) =yi+r
           xq(3) =zi-r
C           XQ(1) =XI-R*SQRT(2.)
C           XQ(2) =YI+R*SQRT(2.)/SQRT(3.)
C           XQ(3) =ZI-R/SQRT(3.)
           IF (nspmd == 1) THEN
            DO j=1,3
              r4 = xq(j)
            CALL write_r_c(r4,1)
            ENDDO
           ELSE
             cnt = cnt + 1
             r4np(cnt) = xq(1)
             cnt = cnt + 1
             r4np(cnt) = xq(2)
             cnt = cnt + 1
             r4np(cnt) = xq(3)
           ENDIF
           xq(1) =xi-r
           xq(2) =yi-r
           xq(3) =zi+r
C           XQ(1) =XI
C           XQ(2) =YI-R*2.*SQRT(2.)/SQRT(3.)
C           XQ(3) =ZI-R/SQRT(3.)
           IF (nspmd == 1) THEN
            DO j=1,3
             r4 = xq(j)
             CALL write_r_c(r4,1)
            ENDDO
           ELSE
             cnt = cnt + 1
             r4np(cnt) = xq(1)
             cnt = cnt + 1
             r4np(cnt) = xq(2)
             cnt = cnt + 1
             r4np(cnt) = xq(3)
           ENDIF
          xq(1) =xi+r
          xq(2) =yi+r
          xq(3) =zi+r
C           XQ(1) =XI
C           XQ(2) =YI
C           XQ(3) =ZI+SQRT(3.)*R
           IF (nspmd == 1) THEN
            DO j=1,3
             r4 = xq(j)
             CALL write_r_c(r4,1)
            ENDDO
           ELSE
             cnt = cnt + 1
             r4np(cnt) = xq(1)
             cnt = cnt + 1
             r4np(cnt) = xq(2)
             cnt = cnt + 1
             r4np(cnt) = xq(3)
           ENDIF
 200   CONTINUE
 100  CONTINUE
C-------------------------------------------------------
      IF (nspmd > 1) THEN
        IF (ispmd==0) THEN
          buf = 3*snnsphg
        ELSE
          buf=1
        ENDIF
        CALL spmd_gather_sph(r4np,numsph*4,buf)
      ENDIF
C
      RETURN