set_admesh.F File Reference

#include "implicit_f.inc"
#include "param_c.inc"
#include "com04_c.inc"
#include "scr17_c.inc"
#include "units_c.inc"
#include "remesh_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	set_admesh (ipart, ipadmesh, padmesh, unitab, lsubmodel)

Function/Subroutine Documentation

set_admesh()

subroutine set_admesh	(	integer, dimension(lipart1,*)	ipart,
		integer, dimension(kipadmesh,*)	ipadmesh,
			padmesh,
		type (unit_type_), intent(in)	unitab,
		type(submodel_data), dimension(*)	lsubmodel )

Definition at line 39 of file set_admesh.F.

C============================================================================
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE hm_option_read_mod
      USE submodel_mod
      USE unitab_mod
      USE names_and_titles_mod , ONLY : nchartitle, ncharkey
C----------------------------------------------------------
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      "param_c.inc"
#include      "com04_c.inc"
#include      "scr17_c.inc"
#include      "units_c.inc"
#include      "remesh_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IPART(LIPART1,*), IPADMESH(KIPADMESH,*)
C     REAL
      my_real
     .       padmesh(kpadmesh,*)
      TYPE(SUBMODEL_DATA) LSUBMODEL(*)
      TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB 
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER ID, N,IP,I,J,INILEV,NPART_ADM,ID_IP
      my_real angl,angldegr,thkerr
      CHARACTER MESS*40
      CHARACTER(LEN=NCHARTITLE) :: TITR
      CHARACTER(LEN=NCHARKEY) :: KEY,KEY2
 
      LOGICAL IS_AVAILABLE
C-----------------------------------------------
      DATA mess /'OPTIONS FOR ADAPTIVE MESHING DEFINITION '/
C-----------------------------------------------
      WRITE(iout,1000)
C------
C--------------------------------------------------
C    READING /ADMESH/GLOBAL
C--------------------------------------------------
 
C--------* START BROWSING MODEL ADMESH OPTIONS *------
C
      CALL hm_option_start('/ADMESH/GLOBAL')
 
      DO n =1,nadmeshg
        titr = ''
 
        CALL hm_option_read_key(lsubmodel,
     .                       option_titr = titr,
     .                       keyword2 = key,
     .                       keyword3 = key2)
 
C
          is_available = .false.
 
          CALL hm_get_intv('LEVEL',levelmax,is_available,lsubmodel)
          CALL hm_get_intv('Iadmrule',iadmrule,is_available,lsubmodel)
          CALL hm_get_intv('Istatcnd',istatcnd,is_available,lsubmodel)
C
C--------* EXTRACT DATAS (REAL VALUES) *------
C
          CALL hm_get_floatv('Tdelay',dtadmesh,is_available,lsubmodel,unitab)
C
 
      ENDDO
C------
 
      WRITE(iout,1100) levelmax,iadmrule,dtadmesh,istatcnd
C------
      WRITE(iout,1200)
 
C--------------------------------------------------
C    READING /ADMESH/SET
C--------------------------------------------------
 
      CALL hm_option_start('/ADMESH/SET')
 
      DO n =1,nadmeshset
         titr = ''
 
         CALL hm_option_read_key(lsubmodel,
     .                       option_id = id,
     .                       option_titr = titr,
     .                       keyword2 = key)
 
C
          is_available = .false.
 
          CALL hm_get_intv('LEVEL',inilev,is_available,lsubmodel)
          CALL hm_get_intv('NIP',npart_adm,is_available,lsubmodel)
C
C--------* EXTRACT DATAS (REAL VALUES) *------
C
          CALL hm_get_floatv('ANGLE2',angldegr,is_available,lsubmodel,unitab)
          CALL hm_get_floatv('Thkerr',thkerr,is_available,lsubmodel,unitab)
C
C
          IF(angldegr <= zero .OR.angldegr >= hundred80)THEN
            CALL ancmsg(msgid=649,
     .                  msgtype=msgerror,
     .                  anmode=aninfo,
     .                  i1=id,
     .                  c1=titr)
          END IF
          angl=angldegr*pi/hundred80
C
C         pour creer les structures LSH4UPL, PSH4UPL, LSH3UPL, PSH3UPL
          IF(thkerr > zero) iadmerrt=1
          IF(thkerr == zero)thkerr=ep30
C
C
          DO i=1,npart_adm
 
             CALL hm_get_int_array_index('PartIds1',id_ip,i,is_available,lsubmodel)
 
             IF(id_ip/=0)THEN
                ip=0
                DO j=1,npart
                  IF(ipart(4,j)==id_ip)THEN
                    ip=j
                    GOTO 50
                  END IF
                END DO
 50            CONTINUE
C
          IF(ip/=0)THEN
            IF(ipart(10,ip)/=0)THEN
                    CALL ancmsg(msgid=644,
     .                     msgtype=msgerror,
     .                     anmode=aninfo,
     .                     i1=ipart(4,ip))
            END IF
            ipart(10,ip)  =levelmax
                  ipadmesh(1,ip)=min(inilev,levelmax)
            padmesh(1,ip) =cos(angl)
            padmesh(2,ip) =thkerr
 
                  WRITE(iout,1250) ipart(4,ip),
     .                             ipadmesh(1,ip),
     .                             angldegr,thkerr
 
          ELSE
                  CALL ancmsg(msgid=646,
     .                   msgtype=msgerror,
     .                   anmode=aninfo,
     .                   i1=id,
     .                   c1=titr,
     .                   i2=id_ip)
          END IF
             END IF
 
          ENDDO
 
      ENDDO
C
 
      RETURN
C-------------------------------------
 
 1000 FORMAT(    /1x,'   ADAPTIVE MESHING         ' /
     .            1x,' --------------------       '// )
 1100 FORMAT(//
     .    '    GLOBAL PARAMETERS FOR ADAPTIVE MESHING    ' //
     .    '    ======================================    ' //
     .    '    NUMBER OF MAXIMUM LEVELS . . .  . . . . . ',i5/,
     .    '    TWO TO ONE ADAPTIVE RULE (0:NO/1:YES) . . ',i5/,
     .    '    TIME BETWEEN 2 CHECKS FOR ADAPTATION. . . ',1pg20.13/,
     .    '    TIME STEP BASED ON THE COARSE MESH (0:NO/1:YES). . ',i5)
 1200 FORMAT(//
     .    '    SETTINGS PER PART FOR ADAPTIVE MESHING    ' //
     .    '    ======================================    ' //)
 1250 FORMAT(
     .    '    part id  . . . . . . . . . . .  . . . . . ',I5/,
     .    '    initial number of levels . . .  . . . . . ',I5/,
     .    '    angle criteria  . . . . . . . . . . . . . ',1PG20.13/,
     .    '    criteria on thickness error . . . . . . . ',1PG20.13/)
      RETURN