hm_read_bcs.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/.
!||====================================================================
!||    hm_read_bcs            ../starter/source/constraints/general/bcs/hm_read_bcs.F
!||--- called by ------------------------------------------------------
!||    lectur                 ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    fretitl                ../starter/source/starter/freform.F
!||    hm_get_intv            ../starter/source/devtools/hm_reader/hm_get_intv.F
!||    hm_option_read_key     ../starter/source/devtools/hm_reader/hm_option_read_key.F
!||    hm_option_start        ../starter/source/devtools/hm_reader/hm_option_start.F
!||    kinset                 ../starter/source/constraints/general/kinset.F
!||    ngr2usr                ../starter/source/system/nintrr.F
!||    usr2sys                ../starter/source/system/sysfus.F
!||--- uses       -----------------------------------------------------
!||    hm_option_read_mod     ../starter/share/modules1/hm_option_read_mod.F
!||    message_mod            ../starter/share/message_module/message_mod.F
!||    submodel_mod           ../starter/share/modules1/submodel_mod.F
!||====================================================================
      SUBROUTINE hm_read_bcs(ICODE     ,ISKEW   ,ITAB    ,ITABM1 ,IKINE  ,
     .                  IGRNOD    ,IBCSLAG ,LAG_NCF ,LAG_NKF,LAG_NHF,
     .                  IKINE1LAG ,ISKN    ,NOM_OPT ,UNITAB ,LSUBMODEL,
     .                  IBCSCYC   ,LBCSCYC )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE unitab_mod
      USE message_mod
      USE groupdef_mod    
      USE submodel_mod        
      USE hm_option_read_mod
      USE names_and_titles_mod , ONLY : nchartitle, ncharfield, ncharkey
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      "scr17_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "sphcom.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ICODE(*), ISKEW(*), ITAB(*), ITABM1(*), IKINE(*),
     .        IBCSLAG(5,*),
     .        LAG_NCF,LAG_NKF,LAG_NHF,IKINE1LAG(*),ISKN(LISKN,*)
      INTEGER NOM_OPT(LNOPT1,*),IBCSCYC(4,*) ,LBCSCYC(2,*) 
C INPUT ARGUMENTS
      TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB 
      TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)
C-----------------------------------------------
      TYPE (GROUP_)  ,TARGET, DIMENSION(NGRNOD)  :: IGRNOD
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,JJ(12), IC, NC, N, NUSR, IS, IC1, IC2, IC3, IC4,
     .        NOSYS, J,J10(10),IGR,IGRS,ISU,IBCALE,J6(6),K,
     .        IC0, IC01, IC02, IC03, IC04, ID ,ILAGM, NBCSLAG,
     .        sub_id,
     .        chkcod,iserr,nod,s_string,sub_index
      INTEGER IUN,IGR1,IGRS1,IGR2,IGRS2,IAD_L,NBY_NI,NBCSCYCI,ICYC,IS0
      CHARACTER MESS*40
      CHARACTER(LEN=NCHARKEY) :: KEY, KEY2
      CHARACTER(LEN=NCHARFIELD) :: STRING
      CHARACTER(LEN=NCHARTITLE) :: TITR
      CHARACTER :: CODE*7
      CHARACTER :: OPT*8
      LOGICAL IS_AVAILABLE
      INTEGER, DIMENSION(:), ALLOCATABLE :: IKINE1
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER USR2SYS,MY_OR,CHECK_NEW,NGR2USR
!
      INTEGER, DIMENSION(:), POINTER :: INGR2USR
C
C-----------------------------------------------
C   D a t a
C-----------------------------------------------
      DATA iun/1/
      DATA mess/'BOUNDARY CONDITIONS                     '/
C======================================================================|
C
      is_available = .false.
      nbcslag = 0
      nbcscyci = 0
      iad_l = 0
      DO i=1,numnod
        iskew(i)=-1
      ENDDO
C
      ALLOCATE(ikine1(3 * numnod))
      DO i=1,3*numnod
        ikine1(i) = 0
      ENDDO
C
C--------------------------------------------------
C START BROWSING MODEL /BCS
C--------------------------------------------------
      CALL hm_option_start('/BCS')
C--------------------------------------------------
C BROWSING MODEL PARTS 1->NBCS
C--------------------------------------------------
      DO i=1,numbcs
        titr = ''
C--------------------------------------------------
C EXTRACT DATAS OF /BCS/... LINE
C--------------------------------------------------
        CALL hm_option_read_key(lsubmodel,
     .                          option_id = id,
     .                          option_titr = titr,
     .                          submodel_index = sub_index,
     .                          keyword2 = key)
        nom_opt(1,i)=id
        CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
        IF (key(1:4) == 'WALL' ) cycle
        ilagm = 0
        IF (key(1:6) == 'LAGMUL' ) ilagm = 1
        icyc = 0
        IF (key(1:6) == 'CYCLIC' ) icyc = 1
C--------------------------------------------------
C EXTRACT DATAS (INTEGER VALUES)
C--------------------------------------------------
        IF (icyc == 1 )THEN
          CALL hm_get_intv('grnd_ID1',igr1,is_available,lsubmodel)
          CALL hm_get_intv('grnd_ID2',igr2,is_available,lsubmodel)
          CALL hm_get_intv('skew_ID',is,is_available,lsubmodel)
        ELSE
          CALL hm_get_intv('dof1',j6(1),is_available,lsubmodel)
          CALL hm_get_intv('dof2',j6(2),is_available,lsubmodel)
          CALL hm_get_intv('dof3',j6(3),is_available,lsubmodel)
          CALL hm_get_intv('dof4',j6(4),is_available,lsubmodel)
          CALL hm_get_intv('dof5',j6(5),is_available,lsubmodel)
          CALL hm_get_intv('dof6',j6(6),is_available,lsubmodel)
          CALL hm_get_intv('inputsystem',is,is_available,lsubmodel)
        END IF !(ICYC == 1 )THEN
c
        IF(is == 0 .AND. sub_index /= 0 ) is = lsubmodel(sub_index)%SKEW
        is0 = is
        CALL hm_get_intv('entityid',igr,is_available,lsubmodel)
C--------------------------------------------------
C
        DO j=0,numskw+min(iun,nspcond)*numsph+nsubmod
          IF(is == iskn(4,j+1)) THEN
            is=j+1
            GO TO 100
          ENDIF
        ENDDO
        CALL ancmsg(msgid=137,anmode=aninfo,msgtype=msgerror,
     .              c1='BOUNDARY CONDITION',
     .              c2='BOUNDARY CONDITION',
     .              i2=is,i1=id,c3=titr)
 100    CONTINUE
C
        IF (icyc == 0 )THEN
          chkcod = 0
          DO j=1,6
            IF (j6(j) >= 2) THEN
              chkcod = 1
            ENDIF
          ENDDO
          IF(chkcod == 1) 
     .         CALL ancmsg(msgid=1051,anmode=aninfo_blind,
     .                msgtype=msgerror,i1=id,c1=titr,c2=code)
          ic1=j6(1)*4 +j6(2)*2 +j6(3)
          ic2=j6(4)*4 +j6(5)*2 +j6(6)
          ic =ic1*512+ic2*64
          ingr2usr => igrnod(1:ngrnod)%ID
          igrs=ngr2usr(igr,ingr2usr,ngrnod)
          IF (igrs==0) THEN
            CALL ancmsg(msgid=678,anmode=aninfo,msgtype=msgerror,
     .                i1=id,i2=igr,c1=titr)
          END IF
          IF (ilagm == 0) THEN
            DO j=1,igrnod(igrs)%NENTITY
              nosys=igrnod(igrs)%ENTITY(j)
              icode(nosys)=my_or(ic,icode(nosys))
              IF(iskew(nosys)==-1.OR.iskew(nosys)==is)THEN
                check_new=is
              ELSE
                CALL ancmsg(msgid=148,anmode=aninfo,msgtype=msgerror,
     .                    i1=itab(nosys),prmod=msg_cumu)
              ENDIF
              iskew(nosys)=check_new
            
              DO k=1,6
                IF(j6(k)/=0)
     .          CALL kinset(1,itab(nosys),ikine(nosys),k,iskew(nosys)
     .                    ,ikine1(nosys))
              ENDDO
             ENDDO
             CALL ancmsg(msgid=148,anmode=aninfo,msgtype=msgerror,
     .                    i1=id,c1=titr,prmod=msg_print)
          ELSE
            nbcslag = nbcslag+1
            ibcslag(1,nbcslag) = igrs
            ibcslag(2,nbcslag) = id
            ibcslag(3,nbcslag) = ic
            ibcslag(4,nbcslag) = is
            ibcslag(5,nbcslag) = id
            DO j=1,igrnod(igrs)%NENTITY
              nosys=igrnod(igrs)%ENTITY(j)
              CALL kinset(512,itab(nosys),ikine(nosys),7,0
     .                    ,ikine1lag(nosys))
              DO k=1,6
                IF(j6(k)/=0) THEN
                  lag_nhf = lag_nhf + 1
                  lag_ncf = lag_ncf + 1
                  IF(is==0) THEN
                    lag_nkf = lag_nkf + 1
                  ELSE
                    lag_nkf = lag_nkf + 3
                  ENDIF
                ENDIF
              ENDDO
            ENDDO
          ENDIF
C--- /BCS/CYCLIC          
        ELSE
C------Imov=0 only fixing skew is allowed         
         IF (iskn(5,is)/=0) THEN
            CALL ancmsg(msgid=1760,anmode=aninfo,msgtype=msgerror,
     .                    i1=id,i2=is0,c1=titr,prmod=msg_print)
         END IF
C----- in SKEW 1:9 (x',y',z'); 10:12 (X0,Y0,Z0)        
         ingr2usr => igrnod(1:ngrnod)%ID
         igrs1=ngr2usr(igr1,ingr2usr,ngrnod)
         igrs2=ngr2usr(igr2,ingr2usr,ngrnod)
         nby_ni = igrnod(igrs1)%NENTITY
         nbcscyci = nbcscyci + 1
         ibcscyc(1,nbcscyci)=iad_l
         ibcscyc(2,nbcscyci)=is
         ibcscyc(3,nbcscyci)=nby_ni
         ibcscyc(4,nbcscyci)=id
         DO j=1,nby_ni
           lbcscyc(1,j+iad_l)=igrnod(igrs1)%ENTITY(j)
           lbcscyc(2,j+iad_l)=igrnod(igrs2)%ENTITY(j)
         END DO
         iad_l =iad_l+nby_ni
        END IF !(IBCSCYC == 0 )THEN
      ENDDO
C
      DEALLOCATE(ikine1)
      RETURN
      END