hm_read_box.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	hm_read_box (ibox, unitab, itabm1, iskn, skew, x, rtrans, lsubmodel)

Function/Subroutine Documentation

hm_read_box()

subroutine hm_read_box	(	type (box_), dimension(nbbox)	ibox,
		type (unit_type_), intent(in)	unitab,
		integer, dimension(numnod), intent(in)	itabm1,
		integer, dimension(liskn,*), intent(in)	iskn,
		intent(in)	skew,
		intent(in)	x,
		intent(in)	rtrans,
		type(submodel_data), dimension(*), intent(in)	lsubmodel )

Definition at line 40 of file hm_read_box.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE my_alloc_mod
      USE unitab_mod
      USE submodel_mod
      USE message_mod
      USE optiondef_mod
      USE hm_option_read_mod
      USE names_and_titles_mod , ONLY : 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 ,DIMENSION(LISKN,*)   ,INTENT(IN) :: ISKN
      INTEGER ,DIMENSION(NUMNOD)    ,INTENT(IN) :: ITABM1
      my_real ,DIMENSION(3,NUMNOD)  ,INTENT(IN) :: x
      my_real ,DIMENSION(LSKEW,*)   ,INTENT(IN) :: skew
      my_real ,DIMENSION(NTRANSF,*) ,INTENT(IN) :: rtrans
      TYPE (UNIT_TYPE_)             ,INTENT(IN) :: UNITAB 
      TYPE(SUBMODEL_DATA),DIMENSION(*) ,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,II,J,UID,LEN,BOXID,IUNIT,FLAGUNIT,
     .        IAD,NBOX,NBOX_RECT,NBOX_CYL,NBOX_SPHER,NBOX_BOX,NLIST
      my_real :: bid
      INTEGER :: IWORK(70000)
      INTEGER INDEX(NBBOX*3),IX1(NBBOX),IX2(NBBOX)
      INTEGER, DIMENSION(:)   ,ALLOCATABLE :: BUFTMP,IBOXTMP
      CHARACTER(LEN=NCHARKEY)    :: KEY,KEY2
      CHARACTER(nchartitle)  :: TITR,MESS
      LOGICAL :: IS_AVAILABLE
c
      DATA mess/'BOX DEFINITION                          '/
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER LISTCNT,NBOXLST
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 (/BOX/RECTA)
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 TYPE (0='BOX',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     IBOX(I)%IBOXBOX(NBOXBOX)  : LIST OF BOXES (in /box/box)
C     IBOX(I)%ENTITY(NENTITY)   : LIST OF ENTITIES (NODES,ELEMS,LINES,SURF)
C=======================================================================
c
      CALL hm_option_count('/BOX/RECTA' ,nbox_rect  )
      CALL hm_option_count('/BOX/CYLIN' ,nbox_cyl   )
      CALL hm_option_count('/BOX/SPHER' ,nbox_spher )
      CALL hm_option_count('/BOX/BOX'   ,nbox_box   )
c      
      nbox = nbox_rect + nbox_cyl + nbox_spher + nbox_box     
c-----------------------------------------------
      iad = 0
      len = 5*nbbox
      CALL my_alloc(buftmp  ,len)
c--------------------------------------------------
c
      CALL read_box_spher(
     .     ibox     ,iad      ,nbox_spher,itabm1   ,x        ,
     .     rtrans   ,unitab   ,lsubmodel )
c
      CALL read_box_cyl(
     .     ibox     ,iad      ,nbox_cyl  ,itabm1   ,x        ,
     .     rtrans   ,unitab   ,lsubmodel )
c
      CALL read_box_rect(
     .     ibox     ,iad      ,nbox_rect ,iskn     ,skew     ,
     .     itabm1   ,x        ,rtrans    ,unitab   ,lsubmodel)
c
      CALL read_box_box(ibox     ,iad      ,nbox_box  ,lsubmodel)
c
c--------------------------------------------------
c     Recherche des ID doubles
c
      CALL my_alloc (iboxtmp  ,nbox )
      iboxtmp(1:nbox) = ibox(1:nbox)%ID
      CALL udouble_igr(iboxtmp,nbox,mess,0,zero)
c
c--------------------------------------------------
c     check /box/box
c--------------------------------------------------
      IF (nbox_box > 0) THEN
        ii = 0
        DO i = 1,nbbox
          IF (ibox(i)%TYPE == 0) THEN                  
            nlist = ibox(i)%NBOXBOX
            boxid = ibox(i)%ID
            titr  = ibox(i)%TITLE
            IF (nlist > 0) THEN
               nlist = nboxlst(ibox(i)%IBOXBOX,nlist ,iboxtmp  ,nbbox,
     .                         buftmp ,buftmp(1+nbbox),buftmp(1+2*nbbox),
     .                         ii,boxid,titr)
              ii = 1
              ibox(i)%NBOXBOX = nlist
            ELSE
              ibox(iad)%NBOXBOX = 0
            ENDIF
          ENDIF
        ENDDO
      ENDIF      
C-----------------------------
      IF (ALLOCATED(iboxtmp)) DEALLOCATE (iboxtmp)
      IF (ALLOCATED(buftmp) ) DEALLOCATE (buftmp )
c-----------
      RETURN