hm_read_submodel.F File Reference

#include "implicit_f.inc"
#include "scr17_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	hm_read_submodel (lsubmodel)

Function/Subroutine Documentation

hm_read_submodel()

subroutine hm_read_submodel

(

type(submodel_data), dimension(*), intent(out)

lsubmodel

)

Definition at line 37 of file hm_read_submodel.F.

C-----------------------------------------------
C   ROUTINE DESCRIPTION :
C   ===================
C   READ //SUBMODELs USING HM_READER
C   BUILD //SUBMODEL DATA STRUCTURE
C-----------------------------------------------
C   DUMMY ARGUMENTS DESCRIPTION:
C   ===================
C
C     NAME         DESCRIPTION              
C    
C     LSUBMODEL    SUBMODEL STRUCTURE       
C-----------------------------------------------
C   M o d u l e s
C----------------------------------------------- 
      USE message_mod
      USE submodel_mod   
      USE hm_option_read_mod
      USE user_id_mod , ONLY : id_limit
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"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C OUTPUT ARGUMENTS
      TYPE(SUBMODEL_DATA),INTENT(OUT)::LSUBMODEL(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  I,CUR_SUBMOD,ISUB_HIERARCHY,ISUBSKEW,STAT
      INTEGER, DIMENSION(:), ALLOCATABLE :: NOSUBMOD,IFATHER,LEVEL,UID_SUB
      INTEGER, DIMENSION(:,:), ALLOCATABLE :: OFFSETS
      INTEGER  NB_BEGIN,SCHAR,SUB_INDEX,NBUNIT_SUB
      LOGICAL :: IS_AVAILABLE
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
C--------------------------------------------------------
      IF(nsubmod > 0)THEN
        ALLOCATE (nosubmod(nsubmod),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='NOSUBMOD')
        ALLOCATE (ifather(nsubmod),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='IFATHER')
        ALLOCATE (level(nsubmod),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='LEVEL')
        ALLOCATE (offsets(7,nsubmod),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='OFFSETS')
        ALLOCATE (uid_sub(nsubmod),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='UID_SUB')
        nosubmod = 0
        ifather = 0
        level = 1
        lsubmodel(1:nsubmod)%NOSUBMOD=0
        lsubmodel(1:nsubmod)%NBTRANS=0
        lsubmodel(1:nsubmod)%LEVEL=0
        lsubmodel(1:nsubmod)%IFATHER=0
        lsubmodel(1:nsubmod)%UID=0
        uid_sub(1:nsubmod)=0
        offsets(1:7,1:nsubmod)=0
      ELSE
        ALLOCATE (nosubmod(0),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='NOSUBMOD')
        ALLOCATE (ifather(0),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='IFATHER')
        ALLOCATE (level(0),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='LEVEL')
        ALLOCATE (offsets(0,0),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='OFFSETS')
        ALLOCATE (uid_sub(0),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                             msgtype=msgerror,
     .                         c1='UID_SUB')
      ENDIF
C
      IF(nsubmod > 0) CALL cpp_submodel_build(ifather,nosubmod,level,offsets,uid_sub)
C
      DO i=1,nsubmod
        lsubmodel(i)%IFATHER = ifather(i)
        lsubmodel(i)%NOSUBMOD = nosubmod(i) 
        lsubmodel(i)%LEVEL = level(i)  
        lsubmodel(i)%UID = uid_sub(i)
        lsubmodel(i)%OFF_DEF    = offsets(1,i)
        lsubmodel(i)%OFF_NOD    = offsets(2,i)
        lsubmodel(i)%OFF_EL     = offsets(3,i)
        lsubmodel(i)%OFF_PART   = offsets(4,i)
        lsubmodel(i)%OFF_MAT    = offsets(5,i)
        lsubmodel(i)%OFF_PROP   = offsets(6,i)
        lsubmodel(i)%OFF_SUBMOD = offsets(7,i)
      ENDDO
c
      isubskew = 1000000000
      DO i=1,nsubmod
        isubskew = isubskew + 1
        IF (lsubmodel(i)%SKEW == 0) lsubmodel(i)%SKEW = isubskew
      ENDDO
      IF (nsubmod /= 0) THEN
        DO i=1,nsubmod
          cur_submod = i
          DO WHILE (lsubmodel(cur_submod)%IFATHER /= 0)
            cur_submod = lsubmodel(cur_submod)%IFATHER
            lsubmodel(i)%LEVEL = lsubmodel(i)%LEVEL + 1
          ENDDO
        ENDDO
      ENDIF
C
      nbunit_sub = 0
      IF(nsubmod > 0)THEN
        CALL hm_option_count('/BEGIN',nb_begin)
        schar = 20
        IF (nb_begin /= 0) THEN
          CALL hm_option_start('/BEGIN')
          DO i=1,nb_begin
            CALL hm_option_read_key(lsubmodel,
     .                              submodel_index = sub_index)
            IF (sub_index /= 0) THEN
              nbunit_sub = nbunit_sub + 1
              lsubmodel(sub_index)%UID = id_limit%UNIT + nbunit_sub
            ENDIF
          ENDDO
c
          
        ENDIF
      ENDIF
C
c      print *,'INTERNAL_ID,USER_ID,FATHER,OFF_DEF,UID'
c      DO I=1,NSUBMOD    
c        print *,I,LSUBMODEL(I)%NOSUBMOD,LSUBMODEL(I)%IFATHER,LSUBMODEL(I)%OFF_DEF,
c     .                                            LSUBMODEL(I)%UID
c      ENDDO
c
      IF (ALLOCATED(nosubmod)) DEALLOCATE(nosubmod)
      IF (ALLOCATED(ifather)) DEALLOCATE(ifather)
      IF (ALLOCATED(level)) DEALLOCATE(level)
      IF (ALLOCATED(offsets)) DEALLOCATE(offsets)
C-----------
      RETURN