create_ellipse_clause.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	create_ellipse_clause (id, title, sub_id, skew, rtrans, clause, nrtrans, lsubmodel, unitab, iskn, iad, ntransf, numskw, liskn, lskew, sskew, siskwn, nspcond, numsph)

Function/Subroutine Documentation

create_ellipse_clause()

subroutine create_ellipse_clause	(	integer, intent(in)	id,
		character(len=nchartitle), intent(in)	title,
		integer, intent(in)	sub_id,
		dimension(lskew,sskew/lskew), intent(in)	skew,
		dimension(ntransf,nrtrans), intent(in)	rtrans,
		type (set_), intent(inout)	clause,
		integer, intent(in)	nrtrans,
		type (submodel_data), dimension(nsubmod), intent(in)	lsubmodel,
		type (unit_type_), intent(in)	unitab,
		integer, dimension(liskn,siskwn/liskn), intent(in)	iskn,
		integer, intent(inout)	iad,
		integer, intent(in)	ntransf,
		integer, intent(in)	numskw,
		integer, intent(in)	liskn,
		integer, intent(in)	lskew,
		integer, intent(in)	sskew,
		integer, intent(in)	siskwn,
		integer, intent(in)	nspcond,
		integer, intent(in)	numsph )

Definition at line 37 of file create_ellipse_clause.F.

C-----------------------------------------------
C   ROUTINE DESCRIPTION :
C   ===================
C   Create PART Clause from LIST
C------------------------------------------------------------------
C   DUMMY ARGUMENTS DESCRIPTION:
C   ===================,
C     JCLAUSE       parameter with HM_READER (current clause read)
C     IS_AVAILABLE  Bool / Result of HM_interface
C     LSUBMODEL     SUBMODEL Structure.
C============================================================================
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE setdef_mod
      USE submodel_mod
      USE message_mod
      USE hm_option_read_mod
      USE unitab_mod
      USE my_alloc_mod
      USE names_and_titles_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(INOUT) :: IAD
      INTEGER, INTENT(IN) :: NTRANSF,NUMSKW,LISKN,LSKEW,NRTRANS,
     .                       SSKEW,SISKWN,NSPCOND,NUMSPH
      INTEGER, INTENT(IN) :: ID,SUB_ID,ISKN(LISKN,SISKWN/LISKN)
      my_real, INTENT(IN) :: skew(lskew,sskew/lskew),rtrans(ntransf,nrtrans)
      CHARACTER(LEN=NCHARTITLE), INTENT(IN) ::  TITLE
!
      TYPE (SET_), INTENT(INOUT) :: CLAUSE
      TYPE (UNIT_TYPE_),INTENT(IN) :: UNITAB 
      TYPE (SUBMODEL_DATA),INTENT(IN) :: LSUBMODEL(NSUBMOD)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,DGR1,DGR,ISKEW
!
      my_real  xg,yg,zg,s_a,s_b,s_c
      LOGICAL :: lFOUND
      LOGICAL :: IS_AVAILABLE
C=======================================================================
      dgr1=0
 
      CALL hm_get_intv('Skew_ID' ,iskew,is_available,lsubmodel)
      CALL hm_get_intv('n' ,dgr1,is_available,lsubmodel)
 
      clause%ELLIPSE_ID_MADYMO=iskew ! No de l'entite qui impose le mvt de la surface.
      !                                --> No systeme Radioss ou MaDyMO.
      !skew:temporary storage of user id
      !get internal id from user id
 
      lfound=.false.                
      DO j=0,numskw+min(1,nspcond)*numsph+nsubmod                      
        IF (iskew==iskn(4,j+1)) THEN                                     
          iskew=j+1  
          lfound=.true.                                                    
          EXIT                                                     
        ENDIF                                                           
      END DO
 
      IF(.NOT.lfound)THEN                                                         
        CALL ancmsg(msgid=184,                                         
     .                    msgtype=msgerror,                                  
     .                    anmode=aninfo,                                     
     .                    c1='SURFACE',                                      
     .                    i1=id,                                             
     .                    c2='SURFACE',                                      
     .                    c3=title,                                           
     .                    i2=iskew)
      ELSE                                                       
        ! Init surface rotation                     
        !DO J=1,9                                                         
          !!BUFSF(IAD+7+J-1)=SKEW(J,ISKEW)                                  
        !END DO                                                           
      ENDIF
 
      CALL hm_get_floatv('Xc' ,xg,is_available,lsubmodel,unitab)
      CALL hm_get_floatv('Yc' ,yg,is_available,lsubmodel,unitab)
      CALL hm_get_floatv('Zc' ,zg,is_available,lsubmodel,unitab)                                                         
      IF(sub_id /= 0)CALL subrotpoint(xg,yg,zg,rtrans,sub_id,lsubmodel)
 
      !BUFSF(IAD+4)=XG                                                  
      !BUFSF(IAD+5)=YG                                                  
      !BUFSF(IAD+6)=ZG                                                  
      !Init application point for force and momentum     
      !/* ellipsoides : defining center ! */      
      !BUFSF(IAD+16)=XG                                                 
      !BUFSF(IAD+17)=YG                                                 
      !BUFSF(IAD+18)=ZG                                                 
 
      CALL hm_get_floatv('a' ,s_a,is_available,lsubmodel,unitab)
      CALL hm_get_floatv('b' ,s_b,is_available,lsubmodel,unitab)
      CALL hm_get_floatv('c' ,s_c,is_available,lsubmodel,unitab)                        
      dgr = 0                             
      IF ( s_a==0. .OR. s_b==0. .OR. s_c==0.) THEN                        
         CALL ancmsg(msgid=185,                                        
     .                     msgtype=msgerror,                                 
     .                     anmode=aninfo,                                    
     .                     i1=id,                                            
     .                     c1=title)                                          
      ENDIF                                           
                 
      IF (dgr==0.AND.dgr1==0) THEN                                     
       dgr1=2                                                          
      ELSEIF (dgr1==0) THEN                                            
       dgr1=dgr                                                        
      ENDIF                                                            
                                                  
      !BUFSF(IAD+1)=S_A                                                  
      !BUFSF(IAD+2)=S_B                                                  
      !BUFSF(IAD+3)=S_C                                                  
      !BUFSF(IAD+36)=DGR1                                               
 
 
      ! Copy in final SET
      ! ------------------
 
      !------------------------------------!
      !  create SURF clause                !
      !------------------------------------!      print*,"clause ELLIPSE_SECOND", ISKEW
      clause%NB_ELLIPSE=1 ! only one ellipsoid per /SET
      CALL my_alloc(clause%ELLIPSE_SKEW,9)
 
      clause%ELLIPSE_IAD_BUFR= iad ! Analytical Surfaces address (reals BUFSF - temp)
 
      clause%ELLIPSE_N=dgr1
      clause%ELLIPSE_XC=xg
      clause%ELLIPSE_YC=yg
      clause%ELLIPSE_ZC=zg
      clause%ELLIPSE_A=s_a
      clause%ELLIPSE_B=s_b
      clause%ELLIPSE_C=s_c
      clause%ELLIPSE_SKEW(1:9)=skew(1:9,iskew)
 
      iad=iad+36
!
      RETURN