admvit.F File Reference

#include "implicit_f.inc"
#include "comlock.inc"
#include "com01_c.inc"
#include "com08_c.inc"
#include "param_c.inc"
#include "remesh_c.inc"
#include "scr17_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	admvit (ixc, ipartc, ixtg, iparttg, ipart, itask, a, v, ar, vr, sh4tree, sh3tree, temp, itherm_fe)

Function/Subroutine Documentation

admvit()

subroutine admvit	(	integer, dimension(nixc,*)	ixc,
		integer, dimension(*)	ipartc,
		integer, dimension(nixtg,*)	ixtg,
		integer, dimension(*)	iparttg,
		integer, dimension(lipart1,*)	ipart,
		integer	itask,
			a,
			v,
			ar,
			vr,
		integer, dimension(ksh4tree,*)	sh4tree,
		integer, dimension(ksh3tree,*)	sh3tree,
			temp,
		integer, intent(in)	itherm_fe )

Definition at line 32 of file admvit.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE remesh_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
#include      "comlock.inc"
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com08_c.inc"
#include      "param_c.inc"
#include      "remesh_c.inc"
#include      "scr17_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IXC(NIXC,*), IPARTC(*), IXTG(NIXTG,*), IPARTTG(*),
     .        IPART(LIPART1,*), ITASK, SH4TREE(KSH4TREE,*),
     .        SH3TREE(KSH3TREE,*)
       my_real
     .        a(3,*),v(3,*),ar(3,*),vr(3,*), temp(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER SH4FT, SH4LT, SH3FT, SH3LT
      INTEGER N, NN, LEVEL, IP, NLEV, LL, IERR
      INTEGER SON,M(4),MC,N1,N2,N3,N4,J,NA,NB
      integer ,INTENT(IN) :: ITHERM_FE
      my_real :: vv, usdt
C-----------------------------------------------
      usdt=one/dt12
C
C     allocation tag
      IF(itask==0)THEN
        tagnod=0
      END IF
C
      CALL my_barrier
C
C-------
      DO level=0,levelmax-1
 
        ll=psh4kin(level+1)-psh4kin(level)
        sh4ft = psh4kin(level)+ 1+itask*ll/ nthread
        sh4lt = psh4kin(level)+ (itask+1)*ll/nthread
 
        DO nn=sh4ft,sh4lt
          n    =lsh4kin(nn)
C
          n1=ixc(2,n)
          n2=ixc(3,n)
          n3=ixc(4,n)
          n4=ixc(5,n)
C
          son=sh4tree(2,n)
C
          mc=ixc(3,son+3)
 
          IF(tagnod(mc)==0)THEN
            tagnod(mc)=1
            DO j=1,3
              vv= fourth*(v(j,n1)+v(j,n2)+v(j,n3)+v(j,n4)
     .             +dt12*(a(j,n1)+a(j,n2)+a(j,n3)+a(j,n4)))
              a(j,mc)=usdt*(vv-v(j,mc))
            END DO
            DO j=1,3
              vv= fourth*(vr(j,n1)+vr(j,n2)+vr(j,n3)+vr(j,n4)
     .             +dt12*(ar(j,n1)+ar(j,n2)+ar(j,n3)+ar(j,n4)))
              ar(j,mc)=usdt*(vv-vr(j,mc))
            END DO
            IF(itherm_fe > 0)
     .        temp(mc)=fourth*(temp(n1)+temp(n2)+temp(n3)+temp(n4))
          END IF
C
          m(1)=ixc(3,son  )
          m(2)=ixc(4,son+1)
          m(3)=ixc(5,son+2)
          m(4)=ixc(2,son+3)
 
          IF(tagnod(m(1))==0)THEN
            tagnod(m(1))=1
            na=min(n1,n2)
            nb=max(n1,n2)
            DO j=1,3
              vv= half*(v(j,na)+v(j,nb)+dt12*(a(j,na)+a(j,nb)))
              a(j,m(1))=usdt*(vv-v(j,m(1)))
            END DO
            DO j=1,3
              vv= half*(vr(j,na)+vr(j,nb)+dt12*(ar(j,na)+ar(j,nb)))
              ar(j,m(1))=usdt*(vv-vr(j,m(1)))
            END DO
            IF(itherm_fe > 0)
     .        temp(m(1))=half*(temp(na)+temp(nb))
          END IF
 
          IF(tagnod(m(2))==0)THEN
            tagnod(m(2))=1
            na=min(n2,n3)
            nb=max(n2,n3)
            DO j=1,3
              vv= half*(v(j,na)+v(j,nb)+dt12*(a(j,na)+a(j,nb)))
              a(j,m(2))=usdt*(vv-v(j,m(2)))
            END DO
            DO j=1,3
              vv= half*(vr(j,na)+vr(j,nb)+dt12*(ar(j,na)+ar(j,nb)))
              ar(j,m(2))=usdt*(vv-vr(j,m(2)))
            END DO
            IF(itherm_fe > 0)
     .        temp(m(2))=half*(temp(na)+temp(nb))
          END IF
 
          IF(tagnod(m(3))==0)THEN
            tagnod(m(3))=1
            na=min(n3,n4)
            nb=max(n3,n4)
            DO j=1,3
              vv= half*(v(j,na)+v(j,nb)+dt12*(a(j,na)+a(j,nb)))
              a(j,m(3))=usdt*(vv-v(j,m(3)))
            END DO
            DO j=1,3
              vv= half*(vr(j,na)+vr(j,nb)+dt12*(ar(j,na)+ar(j,nb)))
              ar(j,m(3))=usdt*(vv-vr(j,m(3)))
            END DO
            IF(itherm_fe > 0)
     .        temp(m(3))=half*(temp(na)+temp(nb))
          END IF
 
          IF(tagnod(m(4))==0)THEN
            tagnod(m(4))=1
            na=min(n4,n1)
            nb=max(n4,n1)
            DO j=1,3
              vv= half*(v(j,na)+v(j,nb)+dt12*(a(j,na)+a(j,nb)))
              a(j,m(4))=usdt*(vv-v(j,m(4)))
            END DO
            DO j=1,3
              vv= half*(vr(j,na)+vr(j,nb)+dt12*(ar(j,na)+ar(j,nb)))
              ar(j,m(4))=usdt*(vv-vr(j,m(4)))
            END DO
            IF(itherm_fe > 0)
     .        temp(m(4))=half*(temp(na)+temp(nb))
          END IF
        END DO
 
        ll=psh3kin(level+1)-psh3kin(level)
        sh3ft = psh3kin(level)+ 1+itask*ll/ nthread
        sh3lt = psh3kin(level)+ (itask+1)*ll/nthread
 
        DO nn=sh3ft,sh3lt
          n    =lsh3kin(nn)
C
          n1=ixtg(2,n)
          n2=ixtg(3,n)
          n3=ixtg(4,n)
C
          son=sh3tree(2,n)
C
          m(1)=ixtg(4,son+3)
          m(2)=ixtg(2,son+3)
          m(3)=ixtg(3,son+3)
 
          IF(tagnod(m(1))==0)THEN
            tagnod(m(1))=1
            na=min(n1,n2)
            nb=max(n1,n2)
            DO j=1,3
              vv= half*(v(j,na)+v(j,nb)+dt12*(a(j,na)+a(j,nb)))
              a(j,m(1))=usdt*(vv-v(j,m(1)))
            END DO
            DO j=1,3
              vv= half*(vr(j,na)+vr(j,nb)+dt12*(ar(j,na)+ar(j,nb)))
              ar(j,m(1))=usdt*(vv-vr(j,m(1)))
            END DO
            IF(itherm_fe > 0)
     .        temp(m(1))=half*(temp(na)+temp(nb))
          END IF
 
          IF(tagnod(m(2))==0)THEN
            tagnod(m(2))=1
            na=min(n2,n3)
            nb=max(n2,n3)
            DO j=1,3
              vv= half*(v(j,na)+v(j,nb)+dt12*(a(j,na)+a(j,nb)))
              a(j,m(2))=usdt*(vv-v(j,m(2)))
            END DO
            DO j=1,3
              vv= half*(vr(j,na)+vr(j,nb)+dt12*(ar(j,na)+ar(j,nb)))
              ar(j,m(2))=usdt*(vv-vr(j,m(2)))
            END DO
            IF(itherm_fe > 0)
     .        temp(m(2))=half*(temp(na)+temp(nb))
          END IF
 
          IF(tagnod(m(3))==0)THEN
            tagnod(m(3))=1
            na=min(n3,n1)
            nb=max(n3,n1)
            DO j=1,3
              vv= half*(v(j,na)+v(j,nb)+dt12*(a(j,na)+a(j,nb)))
              a(j,m(3))=usdt*(vv-v(j,m(3)))
            END DO
            DO j=1,3
              vv= half*(vr(j,na)+vr(j,nb)+dt12*(ar(j,na)+ar(j,nb)))
              ar(j,m(3))=usdt*(vv-vr(j,m(3)))
            END DO
            IF(itherm_fe > 0)
     .        temp(m(3))=half*(temp(na)+temp(nb))
          END IF
        END DO
C
        CALL my_barrier
C
      END DO
C
      RETURN