lcbcsf.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    lcbcsf            ../engine/source/constraints/general/bcs/lcbcsf.F
!||--- called by ------------------------------------------------------
!||    lectur            ../engine/source/input/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg            ../engine/source/output/message/message.F
!||    spmd_glob_isum9   ../engine/source/mpi/interfaces/spmd_th.F
!||    sysfus2           ../engine/source/system/sysfus.F
!||--- uses       -----------------------------------------------------
!||    message_mod       ../engine/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE lcbcsf(ICODE,ISKEW,NUMBCSN,ITAB,ITABM1,
     2                  NPBY ,ISKWN,WEIGHT )
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
      END