lcbcsf.F File Reference

#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "warn_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	lcbcsf (icode, iskew, numbcsn, itab, itabm1, npby, iskwn, weight)

Function/Subroutine Documentation

lcbcsf()

subroutine lcbcsf	(	integer, dimension(*)	icode,
		integer, dimension(*)	iskew,
		integer	numbcsn,
		integer, dimension(*)	itab,
		integer, dimension(*)	itabm1,
		integer, dimension(*)	npby,
		integer, dimension(liskn,*)	iskwn,
		integer, dimension(*)	weight )

Definition at line 34 of file lcbcsf.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NUMBCSN
      INTEGER ICODE(*), ISKEW(*), ITAB(*), ITABM1(*), NPBY(*),
     .        ISKWN(LISKN,*), WEIGHT(*)
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "warn_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER JJ(12), JO(12), IC, NC, N, NUSR, IS, NOSYS, ICO, ICO1,
     .   ICO2, ICO3, ICO4, I, IC1, IC2, IC3, IC4, LL, NOSYSV
      CHARACTER MESS*40
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER SYSFUS2
C     REAL
C-----------------------------------------------
C
      DATA mess/'BOUNDARY CONDITIONS                     '/
C
       ic=0
       nc=1
       DO 10 n=1,numbcsn
       READ (iin,'(I10,4(1X,3I1),I10)') nusr,jj,is
       nosys=sysfus2(nusr,itabm1,numnod)
       nosysv = nosys
       IF(nspmd > 1) CALL spmd_glob_isum9(nosysv,1)
       IF(ispmd==0) THEN
         IF(nosysv==0) THEN
           CALL ancmsg(msgid=202,anmode=aninfo,
     .                 i1=nusr)
           ierr=ierr+1
         END IF
       END IF
       IF(nosys==0)GOTO 10
C
       ico=icode(nosys)
       ico1=ico/512
       ico2=(ico-512*ico1)/64
       ico3=(ico-512*ico1-64*ico2)/8
       ico4=(ico-512*ico1-64*ico2-8*ico3)
       jo(1)=ico1/4
       jo(2)=(ico1-4*jo(1))/2
       jo(3)=(ico1-4*jo(1)-2*jo(2))
       jo(4)=ico2/4
       jo(5)=(ico2-4*jo(4))/2
       jo(6)=(ico2-4*jo(4)-2*jo(5))
       jo(7)=ico3/4
       jo(8)=(ico3-4*jo(7))/2
       jo(9)=(ico3-4*jo(7)-2*jo(8))
       jo(10)=ico4/4
       jo(11)=(ico4-4*jo(10))/2
       jo(12)=(ico4-4*jo(10)-2*jo(11))
C
       DO 5 i=1,12
       IF(jj(i)==0)THEN
        jj(i)=jo(i)
       ELSEIF(jj(i)==2)THEN
        jj(i)=0
       ENDIF
 5     CONTINUE
C
       ic1=jj(1)*4 +jj(2)*2 +jj(3)
       ic2=jj(4)*4 +jj(5)*2 +jj(6)
       ic3=jj(7)*4 +jj(8)*2 +jj(9)
       ic4=jj(10)*4+jj(11)*2+jj(12)
       ic=ic1*512+ic2*64+ic3*8+ic4
       icode(nosys)=ic
       DO 7 ll=0,numskw
 7       IF(is==iskwn(4,ll+1)) iskew(nosys)=ll+1
C       ISKEW(NOSYS)=IS
   10  CONTINUE
C
       IF(ispmd==0) WRITE(iout,1300)
       DO 500 n=1,numnod
       ic=icode(n)
       IF (ic==0) GO TO 500
       ic1=ic/512
       ic2=(ic-512*ic1)/64
       ic3=(ic-512*ic1-64*ic2)/8
       ic4=(ic-512*ic1-64*ic2-8*ic3)
       jj(1)=ic1/4
       jj(2)=(ic1-4*jj(1))/2
       jj(3)=(ic1-4*jj(1)-2*jj(2))
       jj(4)=ic2/4
       jj(5)=(ic2-4*jj(4))/2
       jj(6)=(ic2-4*jj(4)-2*jj(5))
       jj(7)=ic3/4
       jj(8)=(ic3-4*jj(7))/2
       jj(9)=(ic3-4*jj(7)-2*jj(8))
       jj(10)=ic4/4
       jj(11)=(ic4-4*jj(10))/2
       jj(12)=(ic4-4*jj(10)-2*jj(11))
       IF(weight(n)==1)
     .   WRITE(iout,'(1X,I10,4(1X,3I2),3X,I10)')itab(n),jj,
     .                                        iskwn(4,iskew(n))
 500   CONTINUE
      RETURN
C-----------------------------------------------------------------
 1300  FORMAT(/,
     . 1x,'      BOUNDARY CONDITIONS',/
     . 1x,'      -------------------',/
     . 1x,'      NODE  TRANS. ROTAT. GRID   LAGRA.    SKEW',/)
C