read_box_cyl.F File Reference

#include "implicit_f.inc"
#include "com04_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	read_box_cyl (ibox, iad, nbox, itabm1, x, rtrans, unitab, lsubmodel)

Function/Subroutine Documentation

read_box_cyl()

subroutine read_box_cyl	(	type (box_), dimension(nbbox)	ibox,
		integer, intent(inout)	iad,
		integer, intent(in)	nbox,
		integer, dimension(numnod), intent(in)	itabm1,
		intent(in)	x,
		intent(in)	rtrans,
		type (unit_type_), intent(in)	unitab,
		type(submodel_data), dimension(nsubmod), intent(in)	lsubmodel )

Definition at line 40 of file read_box_cyl.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE unitab_mod
      USE submodel_mod
      USE message_mod
      USE optiondef_mod
      USE hm_option_read_mod
      USE names_and_titles_mod , ONLY : nchartitle, 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      "com04_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ,INTENT(IN)                                 :: NBOX
      INTEGER ,INTENT(INOUT)                              :: IAD
      INTEGER ,DIMENSION(NUMNOD), INTENT(IN)              :: ITABM1
      my_real,DIMENSION(3,NUMNOD), INTENT(IN)             :: x
      my_real,DIMENSION(NTRANSF,NRTRANS), INTENT(IN)      :: rtrans
      TYPE (UNIT_TYPE_), INTENT(IN)                       :: UNITAB 
      TYPE(SUBMODEL_DATA), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
      TYPE (BOX_), DIMENSION(NBBOX)                       :: IBOX
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,N1,N2,UID,BOXID,SUB_ID,IUNIT,FLAGUNIT
      my_real :: fac_l,xp1,yp1,zp1,xp2,yp2,zp2,diam
      CHARACTER(LEN=NCHARKEY)    :: KEY
      CHARACTER(LEN=NCHARTITLE)  :: TITR,MESS
      LOGICAL :: IS_AVAILABLE
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER USR2SYS
      DATA mess/'MULTI-BOX DEFINITION                    '/
C-----------------------------------------------
C     IBOX(I)%ID       : BOX IDENTIFIER
C     IBOX(I)%TITLE    : BOX title
C     IBOX(I)%NBOXBOX  : NUMBER OF SUB BOXES (BOXES OF BOXES)
C     IBOX(I)%ISKBOX   : BOX SKEW_ID (RECTA + CYLIN)
C     IBOX(I)%NOD1     : FIRST NODE for box limit definition  - N1 -
C     IBOX(I)%NOD2     : SECOND NODE for box limit definition - N2 -
C     IBOX(I)%TYPE     : BOX SHAPE (1='RECTA',2='CYLIN' ,3='SPHER')
C     IBOX(I)%NBLEVELS : TEMPORARY LEVEL NB OF BOXES
C     IBOX(I)%LEVEL    : FLAG "SUBLEVEL DONE" FOR BOX OF BOXES
C     IBOX(I)%ACTIBOX  : FLAG FOR ACTIVATED BOX FOR (GRNOD,GRSHEL,LINE,SURF...)
C     IBOX(I)%NENTITY  : NUMBER OF BOX ENTITIES (NODES,ELEMS,LINES,SURF)
C                        WITHIN ACTIVATED BOX
C     IBOX(I)%SURFIAD  : temporary address for solid external surface (in box)
C     IBOX(I)%BOXIAD   : temporary address
C     IBOX(I)%DIAM     : BOX diameter (CYLIN + SPHER)
C     IBOX(I)%X1       : coord.X for N1
C     IBOX(I)%Y1       : coord.Y for N1
C     IBOX(I)%Z1       : coord.Z for N1
C     IBOX(I)%X2       : coord.X for N2
C     IBOX(I)%Y2       : coord.Y for N2
C     IBOX(I)%Z2       : coord.Z for N2
C=======================================================================
c
      CALL hm_option_start('/BOX/CYL')
c
c--------------------------------------------------
      DO i = 1,nbox
c
        CALL hm_option_read_key(lsubmodel, option_id   = boxid,
     .                                     unit_id     = uid,
     .                                     submodel_id = sub_id,
     .                                     option_titr = titr,
     .                                     keyword2    = key)
c-----------------------
        IF (uid > 0) THEN
          flagunit = 0
          DO iunit=1,unitab%NUNITS
            IF (unitab%UNIT_ID(iunit) == uid) THEN
              flagunit = 1
              EXIT
            ENDIF
          ENDDO
          IF (uid > 0 .AND. flagunit == 0) THEN
            CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
     .                  i2= uid  ,i1=boxid,
     .                  c1='BOX' ,
     .                  c2='BOX' ,
     .                  c3='TITR')                              
          ENDIF
        ENDIF
c-----------------------
c
        CALL hm_get_intv  ('cylinder_base_node'      ,n1    ,is_available, lsubmodel)
        CALL hm_get_intv  ('cylinder_direction_node' ,n2    ,is_available, lsubmodel)
        CALL hm_get_floatv('cylinder_diameter'       ,diam  ,is_available, lsubmodel, unitab)
c
        CALL hm_get_floatv('cylinder_base_x'         ,xp1   ,is_available, lsubmodel, unitab)
        CALL hm_get_floatv('cylinder_base_y'         ,yp1   ,is_available, lsubmodel, unitab)
        CALL hm_get_floatv('cylinder_base_z'         ,zp1   ,is_available, lsubmodel, unitab)
c
        CALL hm_get_floatv('cylinder_direction_x'    ,xp2   ,is_available, lsubmodel, unitab)
        CALL hm_get_floatv('cylinder_direction_y'    ,yp2   ,is_available, lsubmodel, unitab)
        CALL hm_get_floatv('cylinder_direction_z'    ,zp2   ,is_available, lsubmodel, unitab)
c
c-----------------------
 
        IF (n1 > 0 .and. n2 > 0) THEN
          !using coordinates from user node identifiers
          xp1 = x(1,usr2sys(n1,itabm1,mess,boxid))
          yp1 = x(2,usr2sys(n1,itabm1,mess,boxid))
          zp1 = x(3,usr2sys(n1,itabm1,mess,boxid))
          xp2 = x(1,usr2sys(n2,itabm1,mess,boxid))
          yp2 = x(2,usr2sys(n2,itabm1,mess,boxid))
          zp2 = x(3,usr2sys(n2,itabm1,mess,boxid))   
        ELSE
          !Submodel rotation 
          IF (sub_id > 0) CALL subrotpoint(xp1,yp1,zp1,rtrans,sub_id,lsubmodel)
          IF (sub_id > 0) CALL subrotpoint(xp2,yp2,zp2,rtrans,sub_id,lsubmodel)
        ENDIF
 
        IF ((xp1 == zero .and. yp1 == zero .and. zp1 == zero) .and.
     .      (xp2 == zero .and. yp2 == zero .and. zp2 == zero)) THEN
          CALL ancmsg(msgid=752, msgtype=msgerror, anmode=aninfo,
     .                c1 = 'BOX',
     .                i1 = boxid,
     .                c2 = titr ,
     .                c3 = titr ,
     .                c4 = ' '  )
        END IF
c-----------------------
c
        iad = iad + 1
        ibox(iad)%TITLE   = trim(titr)
        ibox(iad)%ID      = boxid
        ibox(iad)%ISKBOX  = 0
        ibox(iad)%NBLEVELS= 0
        ibox(iad)%LEVEL   = 1
        ibox(iad)%TYPE    = 2
        ibox(iad)%ACTIBOX = 0
        ibox(iad)%NBOXBOX = 0
        ibox(iad)%NOD1    = n1
        ibox(iad)%NOD2    = n2
        ibox(iad)%DIAM    = diam
        ibox(iad)%X1      = xp1
        ibox(iad)%Y1      = yp1
        ibox(iad)%Z1      = zp1
        ibox(iad)%X2      = xp2
        ibox(iad)%Y2      = yp2
        ibox(iad)%Z2      = zp2
        ibox(iad)%SURFIAD = 0
        ibox(iad)%NENTITY = 0
        ibox(iad)%BOXIAD  = 0
c
      ENDDO
 
c-----------
      RETURN