stat_c_off.F File Reference

#include "implicit_f.inc"
#include "com01_c.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	stat_c_off (elbuf_tab, iparg, ipm, igeo, ixc, ixtg, wa, wap0, ipartc, iparttg, ipart_state, stat_indxc, stat_indxtg, sizp0)

Function/Subroutine Documentation

stat_c_off()

subroutine stat_c_off	(	type (elbuf_struct_), dimension(ngroup), target	elbuf_tab,
		integer, dimension(nparg,*)	iparg,
		integer, dimension(npropmi,*)	ipm,
		integer, dimension(npropgi,*)	igeo,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixtg,*)	ixtg,
		double precision, dimension(*)	wa,
		double precision, dimension(*)	wap0,
		integer, dimension(*)	ipartc,
		integer, dimension(*)	iparttg,
		integer, dimension(*)	ipart_state,
		integer, dimension(*)	stat_indxc,
		integer, dimension(*)	stat_indxtg,
		integer	sizp0 )

Definition at line 33 of file stat_c_off.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE elbufdef_mod         
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      "param_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "scr14_c.inc"
#include      "scr16_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER SIZLOC,SIZP0
      INTEGER IXC(NIXC,*),IXTG(NIXTG,*),
     .        IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
     .        IPARTC(*), IPARTTG(*), IPART_STATE(*),
     .        STAT_INDXC(*), STAT_INDXTG(*)
      TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
      double precision WA(*),WAP0(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,N,JJ,LEN,NG, NEL, NFT, ITY, LFT,
     .   LLT, MLW, IPRT,ID,IOFF
      CHARACTER*100 LINE
      TYPE(G_BUFEL_)  ,POINTER :: GBUF     
C-----------------------------------------------
C     4-NODE SHELLS
C-----------------------------------------------
      jj = 0
      IF(stat_numelc==0) GOTO 200
C
      DO ng=1,ngroup
       ity   =iparg(5,ng)
       IF(ity==3) THEN
         gbuf => elbuf_tab(ng)%GBUF   
         mlw   =iparg(1,ng)
         nel   =iparg(2,ng)
         nft   =iparg(3,ng)
 
         lft   =1
         llt   =nel
         DO i=lft,llt
          n  = i + nft
 
          iprt=ipartc(n)
          IF(ipart_state(iprt)==0)cycle
 
          jj = jj + 1
          wa(jj) = ixc(nixc,n)
          jj = jj + 1
          IF (mlw /= 0 .AND. mlw /= 13) THEN
            wa(jj) = gbuf%OFF(i)
          ELSE
            wa(jj) = zero
          ENDIF
         ENDDO
       ENDIF        
      ENDDO
 
 200  CONTINUE
 
      IF(nspmd == 1)THEN
        len=jj
        DO j=1,len
          wap0(j)=wa(j)
        END DO
      ELSE
        len = 0
        CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
      END IF
 
      IF(ispmd==0.AND.len>0) THEN
 
        IF (izipstrs == 0) THEN
          WRITE(iugeo,'(A)')'/INISHE/OFF'
          WRITE(iugeo,'(A)')
     .      '#  SHELLID      IOFF' 
        ELSE
          WRITE(line,'(A)')'/INISHE/OFF' 
               CALL strs_txt50(line,100)
          WRITE(line,'(A)')
     .      '#  SHELLID      IOFF' 
               CALL strs_txt50(line,100)
        ENDIF
        DO n=1,stat_numelc_g
          k=stat_indxc(n)
          j=2*(k-1)
          id  =nint(wap0(j+1))
          ioff=nint(wap0(j+2))
          IF (izipstrs == 0) THEN
            WRITE(iugeo,'(2I10)')id,ioff
          ELSE
            WRITE(line,'(2I10)')id,ioff
            CALL strs_txt50(line,100)
          ENDIF
        END DO
      ENDIF
 
C-----------------------------------------------
C     3-NODE SHELLS
C-----------------------------------------------
      jj = 0
      IF(stat_numeltg==0) GOTO 300
 
C
      DO ng=1,ngroup
       ity   =iparg(5,ng)
       IF(ity==7) THEN
         gbuf => elbuf_tab(ng)%GBUF   
         mlw   =iparg(1,ng)
         nel   =iparg(2,ng)
         nft   =iparg(3,ng)
c
         lft   =1
         llt   =nel
         DO i=lft,llt
          n  = i + nft
 
          iprt=iparttg(n)
          IF(ipart_state(iprt)==0)cycle
 
          jj = jj + 1
          wa(jj) = ixtg(nixtg,n)
          jj = jj + 1
          IF (mlw /= 0 .AND. mlw /= 13) THEN
            wa(jj) = gbuf%OFF(i)
          ELSE
            wa(jj) = zero
          ENDIF
         ENDDO
       ENDIF        
      ENDDO
 
 300  CONTINUE
 
      IF(nspmd == 1)THEN
        len=jj
        DO j=1,len
          wap0(j)=wa(j)
        END DO
      ELSE
        len = 0
        CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
      END IF
 
      IF(ispmd==0.AND.len>0) THEN
 
        IF (izipstrs == 0) THEN
          WRITE(iugeo,'(A)')'/INISH3/OFF'
          WRITE(iugeo,'(A)')
     .      '#   SH3NID      IOFF' 
        ELSE
          WRITE(line,'(A)')'/INISH3/OFF' 
               CALL strs_txt50(line,100)
          WRITE(line,'(A)')
     .      '#   SH3NID      IOFF' 
               CALL strs_txt50(line,100)
        ENDIF
 
        DO n=1,stat_numeltg_g
          k=stat_indxtg(n)
          j=2*(k-1)
          id  =nint(wap0(j+1))
          ioff=nint(wap0(j+2))
          IF (izipstrs == 0) THEN
            WRITE(iugeo,'(2I10)')id,ioff
          ELSE
            WRITE(line,'(2I10)')id,ioff
            CALL strs_txt50(line,100)
          ENDIF
        END DO
      ENDIF
c-----------
      RETURN