Télécharger la plaquette Cast3M


fr en

Télécharger proper.eso

Retour à la liste

Numérotation des lignes : 

proper

  1. C PROPER    SOURCE    SP204843  25/03/14    21:15:09     12201          
  2.  
  3. C-----------------------------------------------------------------------
  4. C  Ce sous programme gere les operateurs 'PLUS', 'MOIN' et 'TOUR',
  5. C  ainsi que les options 'TRAN' et 'ROTA' de de l'operateur 'DEDU'
  6. C
  7. C       OBJ2 = OBJ1 'PLUS' POIN1 / CHPO1 ;
  8. C  OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE
  9. C
  10. C       OBJ2 = OBJ1 'MOIN' POIN1 / CHPO1 ;
  11. C  OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE
  12. C
  13. C       CHPO1 = GEO2 'MOIN' GEO1 ;
  14. C  GEO2, GEO1 : type MAILLAGE, CHPO1 : type CHPO1
  15. C  determination du CHPOINT dont les points support correspond aux
  16. C  points de GEO1 et permettant d'obtenir GEO2 a partir de GEO1.
  17. C
  18. C       OBJ2 = OBJ1 'TOUR' FLOT1 POIN1 (POIN2) ;
  19. C  OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, (RIGIDITE ?)
  20. C  Certaines composantes subissent egalement la rotation.
  21. C  (Appel via tourne.eso - non disponible en DIMEnsion 1)
  22. C
  23. C       OBJ2 = OBJ1 'DEDU' 'TRAN' GEO1 GEO2 ;
  24. C  OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE
  25. C  GEO1, GEO2 : type MAILLAGE (GEO2 image de GEO1)
  26. C  (Appel via dedu.eso)
  27. C
  28. C       OBJ2 = OBJ1 'DEDU' FLOT1 POIN1 (POIN2 si 3D) 'ROTA' GEO1 GEO2 ;
  29. C  OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE
  30. C  GEO1, GEO2 : type MAILLAGE (GEO2 image de GEO1 par la ROTAtion)
  31. C  POIN1 (POIN2) : type POINT (centre ou axe de la rotation)
  32. C  FLOT1 : type FLOTTANT (angle de rotation)
  33. C  (Appel via dedu.eso - non disponible en DIMEnsion 1)
  34. C-----------------------------------------------------------------------
  35. C  Remarques :
  36. C  -----------
  37. C  Dans le cas des syntaxes particulieres (1) POIN2 = POIN1 'PLUS' VECT1
  38. C  (ou POIN2 = POIN1 'MOIN' VECT1), et (2) POIN2 = POIN1 'TOUR' FLOT1
  39. C  PT1 (PT2) , la densite du POIN2 obtenu est, dans le cas (1), la den-
  40. C  site COURANTE definie via l'operateur 'DENSITE', et, dans le cas (2),
  41. C  identique a celle du POIN1.
  42. C  Pour toutes les autres types d'objets et syntaxes, la densite des
  43. C  points transformes est identique a celle des points d'origine.
  44. C-----------------------------------------------------------------------
  45. C  11/1997 : KICH
  46. C  10/2003 : modifications pour le cas IDIM=1
  47. *  07/2007 : PM initialisation de NBREF dans le cas d'un point en entrée
  48. c  07/2009 : BP pour DEDU 'TRAN' avec rigidite, DEDU3.eso teste si IPOIN1 = translation?
  49. C-----------------------------------------------------------------------
  50.  
  51.       SUBROUTINE PROPER(ITYP)
  52.  
  53.       IMPLICIT INTEGER(I-N)
  54.       IMPLICIT REAL*8 (A-H,O-Z)
  55.  
  56.  
  57. -INC PPARAM
  58. -INC CCOPTIO
  59. -INC CCREEL
  60. -INC SMCOORD
  61. -INC SMELEME
  62. -INC CCGEOME
  63. -INC SMRIGID
  64. -INC SMCHPOI
  65. -INC SMMODEL
  66. -INC SMCHAML
  67. -INC SMTABLE
  68. -INC CCTOURN
  69.  
  70.  
  71.       DIMENSION Y(3)
  72.       CHARACTER*4 MOT1
  73.       CHARACTER*8 ITOPE,MO8
  74.  
  75.       SEGMENT ICPR(nbpts)
  76.       SEGMENT ICP1(nbpts)
  77.       SEGMENT MLITY
  78.       CHARACTER*8 LITY2(NTY2)
  79.       ENDSEGMENT
  80.       SEGMENT IPOSI
  81.         INTEGER IPOSIT(mlotab)
  82.       ENDSEGMENT
  83.  
  84. C  IPILO : liste de pointeurs sur les objets DSOBJ a transformer
  85.       SEGMENT IPILO(0)
  86.       SEGMENT DSOBJ
  87.         INTEGER INIPOI,INIFIN
  88.         CHARACTER*8 LETYP
  89.       ENDSEGMENT
  90.  
  91. C  IPLMAIL : liste des maillages elementaires d'un objet a transformer
  92.       SEGMENT IPLMAIL(0)
  93.  
  94. C  ITABEL : contient, initialement, tous les maillages elementaires du
  95. C  maillage initial GEO1, puis tous les maillages elementaires et refe-
  96. C  rence des objets initiaux qui ont deja ete transformes afin d'eviter
  97. C  de les transporter plusieurs fois
  98. C  INOUVEL : contient l'image des maillages elementaires et references
  99. C  par la transformation changeant GEO1 en GEO2
  100. C    GEO1 --> GEO2 et ITABEL(i) --> INOUVEL(i)
  101.       SEGMENT ITABEL(0)
  102.       SEGMENT INOUVEL(0)
  103.  
  104.       idimp1=IDIM+1
  105.       ANGLE=0.D0
  106.  
  107. C  Signification de ITYP (argument de PROPER) :
  108. C   - ITYP = 1 : operateur PLUS
  109. C   - ITYP = 2 : operateur MOIN
  110. C   - ITYP = 3 : operateur TOUR (via sp tourne.eso)
  111. C   - ITYP = 4 : operateur DEDU 'TRAN' (via sp dedu.eso)
  112. C   - ITYP = 5 : operateur DEDU 'ROTA' (via sp dedu.eso)
  113.       IF ((ITYP.EQ.1).OR.(ITYP.EQ.4)) THEN
  114.          ICLE=1
  115.          ISENS=1
  116.       ENDIF
  117.       IF (ITYP.EQ.2) THEN
  118.          ICLE=1
  119.          ISENS=-1
  120.       ENDIF
  121.       IF ((ITYP.EQ.3).OR.(ITYP.EQ.5)) THEN
  122.          ICLE=2
  123. C  Lecture (obligatoire) de l'angle de rotation
  124.          CALL LIRREE(FLO1,1,IRETOU)
  125.          IF (IRETOU.EQ.0) THEN
  126.             CALL ERREUR(884)
  127.             RETURN
  128.          ENDIF
  129.          ANGLE=FLO1-INT(FLO1/360.D0)*360.D0
  130.          IF (ANGLE.GT.180.D0) ANGLE=ANGLE-360.D0
  131.          IF (ANGLE.LT.(-180.D0)) ANGLE=ANGLE+360.D0
  132.          ANGLE=ANGLE*XPI/180.D0
  133.          CO=COS(ANGLE)
  134.          SI=SIN(ANGLE)
  135.       ENDIF
  136. C  Rappel : ICLE=2 (rotation) n'est disponible que si IDIM = 2 ou 3
  137.  
  138. C  Nombre d'objets definissant l'operation a effectuer
  139.       IF ((ITYP.EQ.1).OR.(ITYP.EQ.2))  MINIOBJ=1
  140.       IF ((ITYP.EQ.3).AND.(IDIM.EQ.2)) MINIOBJ=1
  141.       IF ((ITYP.EQ.3).AND.(IDIM.GE.3)) MINIOBJ=2
  142.       IF (ITYP.EQ.4)                   MINIOBJ=2
  143.       IF ((ITYP.EQ.5).AND.(IDIM.EQ.2)) MINIOBJ=3
  144.       IF ((ITYP.EQ.5).AND.(IDIM.GE.3)) MINIOBJ=4
  145.  
  146. C  Tableau des types d'objets pouvant etre transformes
  147.       NTY2=6
  148.       SEGINI MLITY
  149.       LITY2(1)='POINT   '
  150.       LITY2(2)='MAILLAGE'
  151.       LITY2(3)='CHPOINT '
  152.       LITY2(4)='MMODEL  '
  153.       LITY2(5)='MCHAML  '
  154.       LITY2(6)='RIGIDITE'
  155.       SEGDES MLITY
  156.       ITOPE='        '
  157.       itab=0
  158. C  Stockage dans le segment IPILO (pointeur IP1) de tous les objets,
  159. C  donnes en entree a l'operateur et dont le type est inclus dans MLITY
  160. C  (type POINT,MAILLAGE,CHPOINT,MCHAML,MMODEL ou RIGIDITE)
  161.       CALL EMPIL1(IP1,MLITY,IRETOU,itab,iposi)
  162.       IPILO=ip1
  163.       segact ipilo
  164.       IF (IERR.NE.0) GO TO 100
  165.       IF (IRETOU.EQ.20) THEN
  166.          MOTERR(1:30) ='POINT ou MAILLAGE ou CHPOINT'
  167.          CALL ERREUR(881)
  168.          GOTO 100
  169.       ENDIF
  170.  
  171.       IPILO=IP1
  172.       SEGACT IPILO
  173.       NIOBJ=IPILO(/1)
  174. C  Erreur si pas assez d'objets (pas d'objets a transformer de donner)
  175.       IF (NIOBJ.LE.MINIOBJ) THEN
  176.          MOTERR(1:30) =' d autres arguments   '
  177.          CALL ERREUR(881)
  178.          GOTO 100
  179.       ENDIF
  180.  
  181. C  Lecture des MINIOBJ objets definissant la transformation a effectuer
  182. C ======================================================================
  183.       DSOBJ=IPILO(NIOBJ)
  184.       SEGACT DSOBJ
  185.       ITOPE=LETYP
  186.       IPOIN1=INIPOI
  187.       SEGDES DSOBJ
  188. C  Option DEDU 'TRAN' :
  189. C ----------------------
  190.       IF (ITYP.EQ.4) THEN
  191. C  Syntaxe incorrecte : maillage GEO2 attendu
  192.          IF (ITOPE.NE.'MAILLAGE') THEN
  193.             MOTERR(1:30) ='un  MAILLAGE    '
  194.             CALL ERREUR(881)
  195.             GOTO 100
  196.          ENDIF
  197.          IPT2=IPOIN1
  198.          DSOBJ=IPILO(NIOBJ-1)
  199.          SEGACT DSOBJ
  200.          IPT1=INIPOI
  201.          ITOPE=LETYP
  202.          SEGDES DSOBJ
  203. C  Syntaxe incorrecte : maillage GEO1 attendu
  204.          IF (ITOPE.NE.'MAILLAGE') THEN
  205.             MOTERR(1:30) = 'un MAILLAGE   '
  206.             CALL ERREUR(881)
  207.             GOTO 100
  208.          ENDIF
  209.          CALL DEDU1(IPT1,IPT2,ICP1,ITABEL,INOUVEL,IPOIN1)
  210.          IF (IERR.NE.0) GOTO 100
  211.          ITOPE='CHPOINT '
  212.          ICPR=ICP1
  213.          SEGACT ITABEL*MOD,INOUVEL*MOD
  214.       ENDIF
  215. C  Option DEDU 'ROTA' :
  216. C ----------------------
  217.       IF (ITYP.EQ.5) THEN
  218. C  Syntaxe incorrecte : maillage GEO2 attendu
  219.          IF (ITOPE.NE.'MAILLAGE') THEN
  220.             MOTERR(1:30) ='un  MAILLAGE   '
  221.             CALL ERREUR(881)
  222.             GOTO 100
  223.          ENDIF
  224.          IPT2=IPOIN1
  225.          DSOBJ=IPILO(NIOBJ-1)
  226.          SEGACT DSOBJ
  227.          IPT1=INIPOI
  228.          ITOPE=LETYP
  229.          SEGDES DSOBJ
  230. C  Syntaxe incorrecte : maillage GEO1 attendu
  231.          IF (ITOPE.NE.'MAILLAGE') THEN
  232.             MOTERR(1:30) = 'un MAILLAGE    '
  233.             CALL ERREUR(881)
  234.             GOTO 100
  235.          ENDIF
  236.          CALL DEDU1(IPT1,IPT2,ICP1,ITABEL,INOUVEL,IPOIN1)
  237.          IF (IERR.NE.0) GOTO 100
  238.          DSOBJ=IPILO(NIOBJ-2)
  239.          SEGACT DSOBJ
  240.          IPOIN1=INIPOI
  241.          ITOPE=LETYP
  242.          SEGDES DSOBJ
  243. C  Syntaxe incorrecte : POINT attendu (centre 2D, 2nd point axe 3D)
  244.          IF (ITOPE.NE.'POINT   ') THEN
  245.             MOTERR(1:30) = 'un POINT   '
  246.             CALL ERREUR(881)
  247.             GOTO 100
  248.          ENDIF
  249.          SEGACT MCOORD
  250.          IREF=IPOIN1*idimp1-IDIM
  251.          XPT1=XCOOR(IREF)
  252.          YPT1=XCOOR(IREF+1)
  253.          IF (IDIM.LT.3) THEN
  254.             ZPT1=0.D0
  255.             XVEC=0.D0
  256.             YVEC=0.D0
  257.             ZVEC=1.D0
  258.          ELSE
  259.             DSOBJ=IPILO(NIOBJ-3)
  260.             SEGACT DSOBJ
  261.             ITOPE=LETYP
  262.             IPT2=INIPOI
  263.             SEGDES DSOBJ
  264. C  Syntaxe incorrecte : POIN1 attendu en 3D (1er point axe rotation)
  265.             IF (ITOPE.NE.'POINT   ') THEN
  266.                MOTERR(1:30) = 'deux POINTs   '
  267.                CALL ERREUR(881)
  268.                GOTO 100
  269.             ENDIF
  270.             XPT2=XPT1
  271.             YPT2=YPT1
  272.             ZPT2=XCOOR(IREF+2)
  273.             IREF=IPT2*idimp1-IDIM
  274.             XPT1=XCOOR(IREF)
  275.             YPT1=XCOOR(IREF+1)
  276.             ZPT1=XCOOR(IREF+2)
  277.             XVEC=XPT2-XPT1
  278.             YVEC=YPT2-YPT1
  279.             ZVEC=ZPT2-ZPT1
  280.             DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  281.             XVEC=XVEC/DVEC
  282.             YVEC=YVEC/DVEC
  283.             ZVEC=ZVEC/DVEC
  284.          ENDIF
  285.          XV1=-YVEC
  286.          YV1=XVEC
  287.          DV1=XV1*XV1+YV1*YV1
  288.          IF (DV1.GE.0.1D0) THEN
  289.             ZV1=0.D0
  290.             DV1=SQRT(DV1)
  291.             XV1=XV1/DV1
  292.             YV1=YV1/DV1
  293.          ELSE
  294.             XV1=0.D0
  295.             YV1=-ZVEC
  296.             ZV1=YVEC
  297.             DV1=SQRT(YV1*YV1+ZV1*ZV1)
  298.             YV1=YV1/DV1
  299.             ZV1=ZV1/DV1
  300.          ENDIF
  301.          XV2=YVEC*ZV1-ZVEC*YV1
  302.          YV2=ZVEC*XV1-XVEC*ZV1
  303.          ZV2=XVEC*YV1-YVEC*XV1
  304.          ICPR=ICP1
  305.          SEGACT ITABEL*MOD,INOUVEL*MOD
  306.       ENDIF
  307. C  Operateurs PLUS et MOIN :
  308. C ---------------------------
  309.       IF ((ITYP.EQ.1).OR.(ITYP.EQ.2)) THEN
  310.          IF ((ITOPE.NE.'MAILLAGE').AND.(ITOPE.NE.'POINT   ').AND.
  311.      .        (ITOPE.NE.'CHPOINT ')) THEN
  312. C  Syntaxe incorrecte : le vecteur VEC1, le champ par point CHPO1 ou
  313. C  le maillage GEO1 etait attendu
  314.             MOTERR(1:30) ='un POINT, CHPOINT ou MAILLAGE'
  315.             CALL ERREUR(881)
  316.             GOTO 100
  317.          ENDIF
  318. C  Deplacement (translation) donne par un vecteur VEC1
  319.          IF (ITOPE.EQ.'POINT   ') THEN
  320.             IREF=(IPOIN1-1)*idimp1
  321.             SEGACT MCOORD
  322.             DO i=1,IDIM
  323.                Y(i)=XCOOR(IREF+i)*ISENS
  324.             ENDDO
  325. C  Deplacement donne par un champ point CHPO1
  326.          ELSE IF (ITOPE.EQ.'CHPOINT ') THEN
  327. C  Cas particulier : operateur MOINS - maillage GEO1 donne
  328.          ELSE IF (ITOPE.EQ.'MAILLAGE') THEN
  329.             IPT1=IPOIN1
  330.             DSOBJ=IPILO(NIOBJ-1)
  331.             SEGACT DSOBJ
  332.             IPT2=INIPOI
  333.             ITOPE=LETYP
  334.             SEGDES DSOBJ
  335. C  Syntaxe incorrecte : maillage GEO2 attendu
  336.             IF (ITOPE.NE.'MAILLAGE') THEN
  337.                MOTERR(1:30) = 'un MAILLAGE     '
  338.                CALL ERREUR(881)
  339.                GOTO 100
  340.             ENDIF
  341.             GOTO 500
  342.          ENDIF
  343.          SEGINI ICPR,INOUVEL,ITABEL
  344.       ENDIF
  345. C  Operateur TOUR :
  346. C ------------------
  347.       IF (ITYP.EQ.3) THEN
  348. C  Syntaxe incorrecte : POINT attendu (centre 2D, 2nd point axe 3D)
  349.          IF (ITOPE.NE.'POINT   ') THEN
  350.             MOTERR(1:30) = 'un POINT    '
  351.             CALL ERREUR(881)
  352.             GOTO 100
  353.          ENDIF
  354.          SEGACT MCOORD
  355.          IREF=IPOIN1*idimp1-IDIM
  356.          XPT1=XCOOR(IREF)
  357.          YPT1=XCOOR(IREF+1)
  358.          IF (IDIM.LT.3) THEN
  359.             ZPT1=0.D0
  360.             XVEC=0.D0
  361.             YVEC=0.D0
  362.             ZVEC=1.D0
  363.          ELSE
  364.             DSOBJ=IPILO(NIOBJ-1)
  365.             SEGACT DSOBJ
  366.             ITOPE=LETYP
  367.             IPT2=INIPOI
  368.             SEGDES DSOBJ
  369. C  Syntaxe incorrecte : POINT attendu en 3D (1er point axe rotation)
  370.             IF (ITOPE.NE.'POINT   ') THEN
  371.                MOTERR(1:30) = 'deux POINTs    '
  372.                CALL ERREUR(881)
  373.                GOTO 100
  374.             ENDIF
  375.             XPT2=XPT1
  376.             YPT2=YPT1
  377.             ZPT2=XCOOR(IREF+2)
  378.             IREF=IPT2*idimp1-IDIM
  379.             XPT1=XCOOR(IREF)
  380.             YPT1=XCOOR(IREF+1)
  381.             ZPT1=XCOOR(IREF+2)
  382.             XVEC=XPT2-XPT1
  383.             YVEC=YPT2-YPT1
  384.             ZVEC=ZPT2-ZPT1
  385.             DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  386.             XVEC=XVEC/DVEC
  387.             YVEC=YVEC/DVEC
  388.             ZVEC=ZVEC/DVEC
  389.          ENDIF
  390.          XV1=-YVEC
  391.          YV1=XVEC
  392.          DV1=XV1*XV1+YV1*YV1
  393.          IF (DV1.GE.0.1D0) THEN
  394.             ZV1=0.D0
  395.             DV1=SQRT(DV1)
  396.             XV1=XV1/DV1
  397.             YV1=YV1/DV1
  398.          ELSE
  399.             XV1=0.D0
  400.             YV1=-ZVEC
  401.             ZV1=YVEC
  402.             DV1=SQRT(YV1*YV1+ZV1*ZV1)
  403.             YV1=YV1/DV1
  404.             ZV1=ZV1/DV1
  405.          ENDIF
  406.          XV2=YVEC*ZV1-ZVEC*YV1
  407.          YV2=ZVEC*XV1-XVEC*ZV1
  408.          ZV2=XVEC*YV1-YVEC*XV1
  409.          SEGINI ICPR,INOUVEL,ITABEL
  410.       ENDIF
  411.  
  412. C  Boucle sur tous les objets a transformer
  413. C ==========================================
  414.       DO 200 L=1,NIOBJ-MINIOBJ
  415.          DSOBJ=IPILO(L)
  416.          SEGACT DSOBJ*MOD
  417.          SEGINI IPLMAIL
  418. C  IPLMAIL contient tous les maillages elementaires de l'objet L initial
  419. C  Creation objet transforme (INIFIN) par copie objet initial (INIPOI)
  420.          IF (LETYP.EQ.'MAILLAGE') THEN
  421.             IPLMAIL(**)=INIPOI
  422.          ELSE IF (LETYP.EQ.'CHPOINT ') THEN
  423.             MCHPO1=INIPOI
  424.             CALL COPIE2(MCHPO1,MCHPOI)
  425.             INIFIN=MCHPOI
  426.             SEGACT MCHPOI
  427.             DO i=1,IPCHP(/1)
  428.                MSOUPO=IPCHP(i)
  429.                SEGACT MSOUPO
  430.                IPLMAIL(**)=IGEOC
  431.                SEGDES MSOUPO
  432.             ENDDO
  433.             SEGDES MCHPOI
  434.          ELSE IF (LETYP.EQ.'MCHAML  ') THEN
  435.             MCHEL1=INIPOI
  436.             CALL COPIE8(MCHEL1,MCHELM)
  437.             INIFIN=MCHELM
  438.             SEGACT MCHELM
  439.             DO i=1,IMACHE(/1)
  440.                IPLMAIL(**)=IMACHE(i)
  441.             ENDDO
  442.             SEGDES MCHELM
  443.          ELSE IF (LETYP.EQ.'MMODEL  ') THEN
  444.             MMODE1=INIPOI
  445.             CALL COPIE9(MMODE1,MMODEL)
  446.             INIFIN=MMODEL
  447.             SEGACT MMODEL
  448.             DO i=1,KMODEL(/1)
  449.                IMODEL=KMODEL(i)
  450.                SEGACT IMODEL
  451.                IPLMAIL(**)=IMAMOD
  452.                SEGDES IMODEL
  453.             ENDDO
  454.             SEGDES MMODEL
  455.          ELSE IF (LETYP.EQ.'RIGIDITE') THEN
  456. C  Syntaxe incorrecte  SSI  objets RIGIDITE transformes via un CHPOINT
  457. c  IPOIN1 qui n'est pas une translation => test dans DEDU3
  458.             XERR1 = 0.D0
  459.             IF (ITOPE.EQ.'CHPOINT ') THEN
  460.                if(ITYP.eq.4)  call DEDU3(IPOIN1,XERR1)
  461.                if(ITYP.eq.5)  XERR1 = 1.D0
  462.             ENDIF
  463.             IF (XERR1.GT.(1.D-10)) THEN
  464.                CALL ERREUR(882)
  465.                GOTO 100
  466.             ENDIF
  467.             RI1=INIPOI
  468.             SEGINI,MRIGID=RI1
  469.             INIFIN=MRIGID
  470.             DO i=1,IRIGEL(/2)
  471.                IPLMAIL(**)=IRIGEL(1,i)
  472.             ENDDO
  473.             SEGDES MRIGID
  474.          ELSE IF (LETYP.EQ.'POINT   ') THEN
  475. C  Cas particulier syntaxe : POIN2 = POIN1 PLUS (MOIN) CHPO1;
  476. C  Creation d'un maillage IPT9 contenant un element POI1
  477.             IF (ITOPE.EQ.'CHPOINT ') THEN
  478.                NBNN=1
  479.                NBELEM=1
  480.                NBSOUS=0
  481.                NBREF=0
  482.                SEGINI MELEME
  483.                NUM(1,1)=INIPOI
  484.                SEGDES MELEME
  485.                IPT9=MELEME
  486.                IPLMAIL(**)=IPT9
  487.             ELSE
  488. C  Cas particulier syntaxe : POIN2 = POIN1 PLUS (MOIN) VECT1;
  489.                GOTO 210
  490.             ENDIF
  491.          ENDIF
  492. C  Boucle sur les sous-zones de l'objet L a transformer
  493. C  Pour ne transformer qu'une seule fois les maillages elementaires, on
  494. C  verifie si la zone elementaire est presente dans ITABEL. Si ce n'est
  495. C  pas le cas, on doit alors transformer cette zone et on met a jour
  496. C  ITABEL et INOUVEL en consequence.
  497. C  IPLMAIL contient initialement le maillage a transformer et a la fin
  498. C  de la boucle le maillage image (transforme)
  499.          DO IMEL=1,IPLMAIL(/1)
  500.             MELEME=IPLMAIL(IMEL)
  501.             SEGACT MELEME
  502.             NBSOUS=LISOUS(/1)
  503.             NBREF=LISREF(/1)
  504. C  Transformation des sous-objets s'ils existents
  505.             IF (NBSOUS.NE.0) THEN
  506.                NBNN=0
  507.                NBELEM=0
  508.                SEGINI IPT1
  509. C  Boucle sur les sous-objets
  510.                DO J=1,NBSOUS
  511.                   IF (ITABEL(/1).NE.0) THEN
  512.                      DO K=1,ITABEL(/1)
  513. C Verification si ce maillage n'a pas deja ete transforme
  514.                         IF (ITABEL(K).EQ.LISOUS(J)) THEN
  515.                            IPT1.LISOUS(J)=INOUVEL(K)
  516.                            GOTO 201
  517.                         ENDIF
  518.                      ENDDO
  519.                   ENDIF
  520.                   MELE1=LISOUS(J)
  521. C  Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent
  522. C  la transformation i.e. ont une image, soit ICP(i) non nul
  523.                   IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN
  524.                      CALL DEDU2(MELE1,ICPR,IRETOU,ITYP)
  525.                      IF (IERR.NE.0) THEN
  526.                         SEGSUP IPLMAIL
  527.                         GOTO 300
  528.                      ENDIF
  529.                      IF (IRETOU.NE.0) THEN
  530.                         INTERR(1)=L
  531.                         CALL ERREUR(883)
  532.                         SEGSUP IPLMAIL
  533.                         GOTO 300
  534.                      ENDIF
  535.                   ENDIF
  536.                   ITABEL(**)=LISOUS(J)
  537. C  Operateur DEDU : activation obligatoire du segment ICPR
  538.                   IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR
  539. C  Transformation du maillage MELE1 en NOUV suivant ICLE
  540.                   IF ((ITOPE.EQ.'POINT   ').AND.(ICLE.EQ.1)) THEN
  541.                      CALL ADDITI(Y,MELE1,NOUV,ICPR)
  542.                   ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1)) THEN
  543.                      CALL CHDITI(IPOIN1,MELE1,NOUV,ICPR,ISENS)
  544.                   ELSE IF (ICLE.EQ.2) THEN
  545.                      CALL ADDITI(Y,MELE1,NOUV,ICPR)
  546.                   ENDIF
  547.                   INOUVEL(**)=NOUV
  548.                   IPT1.LISOUS(J)=NOUV
  549.  201              CONTINUE
  550.                ENDDO
  551. C  Boucle sur les references si elles existent
  552.                IF (NBREF.NE.0) THEN
  553.                   DO J=1,NBREF
  554.                      DO K=1,ITABEL(/1)
  555. C Verification si ce maillage n'a pas deja ete transforme
  556.                         IF (ITABEL(K).EQ.LISREF(J)) THEN
  557.                            IPT1.LISREF(J)=INOUVEL(K)
  558.                            GOTO 202
  559.                         ENDIF
  560.                      ENDDO
  561.                      MELE1=LISREF(J)
  562. C  Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent
  563. C  la transformation i.e. ont une image, soit ICP(i) non nul
  564.                      IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN
  565.                         CALL DEDU2(MELE1,ICPR,IRETOU,ITYP)
  566.                         IF (IERR.NE.0) THEN
  567.                            SEGSUP IPLMAIL
  568.                            GOTO 300
  569.                         ENDIF
  570.                         IF (IRETOU.NE.0) THEN
  571.                            INTERR(1)=L
  572.                            CALL ERREUR(883)
  573.                            SEGSUP IPLMAIL
  574.                            GOTO 300
  575.                         ENDIF
  576.                      ENDIF
  577.                      ITABEL(**)=LISREF(J)
  578. C  Operateur DEDU : activation obligatoire du segment ICPR
  579.                      IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR
  580. C  Transformation du maillage MELE1 en NOUV suivant ICLE
  581.                      IF ((ITOPE.EQ.'POINT   ').AND.(ICLE.EQ.1)) THEN
  582.                         CALL ADDITI(Y,MELE1,NOUV,ICPR)
  583.                      ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1))
  584.      $                       THEN
  585.                         CALL CHDITI(IPOIN1,MELE1,NOUV,ICPR,ISENS)
  586.                      ELSE IF (ICLE.EQ.2) THEN
  587.                         CALL ADDITI(Y,MELE1,NOUV,ICPR)
  588.                      ENDIF
  589.                      INOUVEL(**)=NOUV
  590.                      IPT1.LISREF(J)=NOUV
  591.  202                 CONTINUE
  592.                   ENDDO
  593.                ENDIF
  594.                SEGDES IPT1
  595.                IPLMAIL(IMEL)=IPT1
  596. C L'objet est elementaire
  597.             ELSE
  598.                IF (ITABEL(/1).NE.0) THEN
  599. C Verification si ce maillage n'a pas deja ete transforme
  600.                   DO K=1,ITABEL(/1)
  601.                      IF (ITABEL(K).EQ.MELEME) THEN
  602.                         IPLMAIL(IMEL)=INOUVEL(K)
  603.                         GOTO 203
  604.                      ENDIF
  605.                   ENDDO
  606.                ENDIF
  607. C  Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent
  608. C  la transformation i.e. ont une image, soit ICP(i) non nul
  609.                IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN
  610.                   CALL DEDU2(MELEME,ICPR,IRETOU,ITYP)
  611.                   IF (IERR.NE.0) THEN
  612.                      SEGSUP IPLMAIL
  613.                      GOTO 300
  614.                   ENDIF
  615.                   IF (IRETOU.NE.0) THEN
  616.                      INTERR(1)=L
  617.                      CALL ERREUR(883)
  618.                      SEGSUP IPLMAIL
  619.                      GOTO 300
  620.                   ENDIF
  621.                ENDIF
  622.                ITABEL(**)=MELEME
  623. C  Operateur DEDU : activation obligatoire du segment ICPR
  624.                IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR
  625. C  Transformation du maillage MELE1 en NOUV suivant ICLE
  626.                IF ((ITOPE.EQ.'POINT   ').AND.(ICLE.EQ.1)) THEN
  627.                   CALL ADDITI(Y,MELEME,NOUV,ICPR)
  628.                ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1)) THEN
  629.                   CALL CHDITI(IPOIN1,MELEME,NOUV,ICPR,ISENS)
  630.                ELSE IF (ICLE.EQ.2) THEN
  631.                   CALL ADDITI(Y,MELEME,NOUV,ICPR)
  632.                ENDIF
  633.                INOUVEL(**)=NOUV
  634.                IPLMAIL(IMEL)=NOUV
  635.             ENDIF
  636.  203        CONTINUE
  637.             SEGDES MELEME
  638.          ENDDO
  639. C  Fin de la boucle : le maillage support de l'objet L a ete transforme
  640. C  Mise a jour de INIFIN (DSOBJ) en consequence avec transformation des
  641. C     composantes si l'objet est un CHPOINT ou MCHAML et ICLE=2
  642. C     (rotation)
  643.  210     CONTINUE
  644.          IF (LETYP.EQ.'MAILLAGE') THEN
  645.             INIFIN=IPLMAIL(1)
  646.          ELSE IF (LETYP.EQ.'CHPOINT ') THEN
  647.             MCHPOI=INIFIN
  648.             SEGACT MCHPOI*MOD
  649.             DO i=1,IPCHP(/1)
  650.                MSOUPO=IPCHP(i)
  651.                SEGACT MSOUPO*MOD
  652.                IGEOC=IPLMAIL(i)
  653.                SEGDES MSOUPO
  654.             ENDDO
  655.             SEGDES MCHPOI
  656.             IF (ICLE.EQ.2) CALL TOCH1(MCHPOI,'CHPOINT ',IRETOU)
  657.          ELSE IF (LETYP.EQ.'MCHAML  ') THEN
  658.             MCHELM=INIFIN
  659.             SEGACT MCHELM*MOD
  660.             DO i=1,IMACHE(/1)
  661.                IMACHE(i)=IPLMAIL(i)
  662.             ENDDO
  663.             SEGDES MCHELM
  664.             IF (ICLE.EQ.2) CALL TOCH1(MCHELM,'MCHAML  ',IRETOU)
  665.          ELSE IF (LETYP.EQ.'MMODEL  ') THEN
  666.             MMODEL=INIFIN
  667.             SEGACT MMODEL*MOD
  668.             DO i=1,KMODEL(/1)
  669.                IMODEL=KMODEL(i)
  670.                SEGACT IMODEL*MOD
  671.                IMAMOD=IPLMAIL(i)
  672.                SEGDES IMODEL
  673.             ENDDO
  674.             SEGDES MMODEL
  675.          ELSE IF (LETYP.EQ.'RIGIDITE') THEN
  676.             MRIGID=INIFIN
  677.             SEGACT MRIGID*MOD
  678.             DO i=1,IRIGEL(/2)
  679.                IRIGEL(1,i)=IPLMAIL(i)
  680.             ENDDO
  681.             SEGDES MRIGID
  682.          ELSE IF (LETYP.EQ.'POINT   ') THEN
  683. C Cas particulier - Syntaxe : POIN2 = POIN1 'PLUS' VECT1 ;
  684.             IF (ITOPE.EQ.'POINT   ') THEN
  685.                IPOIN1=INIPOI
  686.                if(icpr(ipoin1).ne.0) then
  687.                   inifin=icpr(ipoin1)
  688.                else
  689.                   segact mcoord*mod
  690.                   NBPTS=nbpts+1
  691.                   inifin=nbpts
  692.                   SEGADJ MCOORD
  693.                   IREF=(IPOIN1-1)*idimp1
  694.                   IPTFIN=(NBPTS-1)*idimp1
  695.                   IF ((ICPR(IPOIN1).EQ.0).AND.(ICLE.EQ.1)) THEN
  696.                      DO i=1,IDIM
  697.                         XCOOR(IPTFIN+i)=XCOOR(IREF+i)+Y(i)
  698.                      ENDDO
  699.                      XCOOR(IPTFIN+idimp1)=DENSIT
  700.                   ELSE IF ((ICPR(IPOIN1).EQ.0).AND.(ICLE.EQ.2)) THEN
  701.                      XD=XCOOR(IREF+1)-XPT1
  702.                      YD=XCOOR(IREF+2)-YPT1
  703.                      ZD=0.D0
  704.                      IF (IDIM.GE.3) ZD=XCOOR(IREF+3)-ZPT1
  705.                      XE=XD*XV1+YD*YV1+ZD*ZV1
  706.                      YE=XD*XV2+YD*YV2+ZD*ZV2
  707.                      ZE=XD*XVEC+YD*YVEC+ZD*ZVEC
  708.                      XD=XE*CO-YE*SI
  709.                      YD=XE*SI+YE*CO
  710.                      ZD=ZE
  711.                      XCOOR(IPTFIN+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  712.                      XCOOR(IPTFIN+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  713.                      IF (IDIM.GE.3) XCOOR(IPTFIN+3)=XD*ZV1+YD*ZV2+ZD
  714.      $                    *ZVEC+ZPT1
  715.                      XCOOR(IPTFIN+idimp1)=XCOOR(IREF+idimp1)
  716. C**   ELSE IF (ICPR(IPOIN1).NE.0) THEN
  717.                   ENDIF
  718.                   ICPR(IPOIN1)=INIFIN
  719.                endif
  720.             ELSE
  721. C Cas particulier - Syntaxe 2 : POIN2 = POIN1 'PLUS' CHPO1 ;
  722.                IPT9=IPLMAIL(1)
  723.                SEGACT IPT9
  724.                INIFIN=IPT9.NUM(1,1)
  725.                SEGSUP IPT9
  726.             ENDIF
  727.          ENDIF
  728.          SEGDES DSOBJ
  729.          SEGSUP IPLMAIL
  730.  200  CONTINUE
  731. C  Fin de la boucle sur les objets DSOBJ a transformer
  732.  
  733. C  Ecriture dans la pile des objets transformes
  734. * cas particulier si on avait lu une table
  735.       if(itab.ne.0) then
  736.          mtable=itab
  737.          segact mtable*mod
  738.          segact iposi
  739.       endif
  740.       DO i=NIOBJ-MINIOBJ,1,-1
  741.          DSOBJ=IPILO(i)
  742.          SEGACT DSOBJ
  743. *     
  744.          IF(LETYP.EQ.'MMODEL  ') THEN
  745.             MMODEL=INIFIN
  746.             SEGACT MMODEL
  747.             NSOUS = KMODEL(/1)
  748. * on change les maillages des modeles pointes par un modele MELANGE
  749. * et le pointeur du modele
  750.             do im = 1,NSOUS
  751.                imodel = kmodel(im)
  752.                segact imodel*mod
  753.                if (formod(1).eq.'MELANGE') then
  754.                   if (ivamod(/1).ge.1) then
  755.                      do ivm1 = 1,ivamod(/1)
  756.                         if (tymode(ivm1).eq.'IMODEL') then
  757.                            imode1 = ivamod(ivm1)
  758.                            segini,imode2=imode1
  759.                            imode2.imamod = imamod
  760.                            ivamod(ivm1) = imode2
  761.                            segdes imode2
  762.                         endif
  763.                      enddo
  764.                   endif
  765.                endif
  766.                segdes imodel
  767.             enddo
  768.             SEGDES MMODEL
  769.          ENDIF
  770. *
  771.          IF(itab.ne.0)  then
  772.             ipotab=iposit(i)
  773.             mtabiv(ipotab)=inifin
  774.          ELSE
  775.             MO8  = LETYP
  776.             IPOI1=INIFIN
  777.             CALL ACTOBJ(MO8,IPOI1,1)
  778.             CALL ECROBJ(MO8,IPOI1)
  779.          ENDIF
  780.          SEGDES DSOBJ
  781.       ENDDO
  782.       if( itab.ne.0) then
  783.          call ECROBJ('TABLE   ',mtable)
  784.          segdes mtable
  785.          segsup iposi
  786.       endif
  787.  
  788. C  Un peu de menage
  789.  300  CONTINUE
  790.       SEGSUP ICPR,ITABEL,INOUVEL
  791.       GOTO 100
  792.  
  793. C  Cas particulier - Operateur MOINS : CHPO1 = 'MOIN' GEO1 GEO2 ;
  794. c  Calcul du CHPOINT permettant de passer de GEO1 a GEO2
  795.  500  CONTINUE
  796.       SEGINI ICP1
  797.       SEGACT IPT1,IPT2
  798.       NBSOUS1=IPT1.LISOUS(/1)
  799.       NBSOUS2=IPT2.LISOUS(/1)
  800. *Gounand : Utilité ?      NBREF1=IPT1.LISREF(/1)
  801. *G      NBREF2=IPT2.LISREF(/1)
  802.       IF (NBSOUS1.NE.NBSOUS2) GOTO 502
  803. *G      IF (NBREF1.NE.NBREF2) GOTO 502
  804.       IF (NBSOUS1.EQ.0) THEN
  805.          IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 502
  806.          IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 502
  807.          IF (IPT1.NUM(/2).NE.IPT2.NUM(/2)) GOTO 502
  808.          CALL PROCHP(IPT1,IPT2,IPOIN1,ICP1)
  809.          IF (IERR.NE.0) GOTO 502
  810.       ELSE IF (NBSOUS1.NE.0) THEN
  811.          DO j=1,NBSOUS1
  812.             IPT3=IPT1.LISOUS(j)
  813.             IPT4=IPT2.LISOUS(j)
  814.             SEGACT IPT3,IPT4
  815.             NBSOUS3=IPT3.LISOUS(/1)
  816.             NBSOUS4=IPT4.LISOUS(/1)
  817. *G          NBREF3=IPT3.LISREF(/1)
  818. *G          NBREF4=IPT4.LISREF(/1)
  819.             IF (NBSOUS3.NE.NBSOUS4) GOTO 501
  820. *G          IF (NBREF3.NE.NBREF4) GOTO 501
  821.             IF (IPT3.ITYPEL.NE.IPT4.ITYPEL) GOTO 501
  822.             IF (IPT3.NUM(/1).NE.IPT4.NUM(/1)) GOTO 501
  823.             IF (IPT3.NUM(/2).NE.IPT4.NUM(/2)) GOTO 501
  824.             SEGDES IPT3,IPT4
  825.             CALL PROCHP(IPT3,IPT4,IPOIN1,ICP1)
  826.             IF (IERR.NE.0) GOTO 501
  827.             IF (j.EQ.1) THEN
  828.                IPCHP0=IPOIN1
  829.             ELSE
  830.                CALL FUCHPO(IPCHP0,IPOIN1,IRET)
  831.                IPCHP0=IRET
  832.             ENDIF
  833.             IF (IERR.NE.0) GOTO 501
  834.          ENDDO
  835.          IPOIN1=IPCHP0
  836.       ENDIF
  837.       SEGDES IPT1,IPT2
  838. C  Ecriture du CHPOINT calcule
  839.       CALL ACTOBJ('CHPOINT ',IPOIN1,1)
  840.       CALL ECROBJ('CHPOINT ',IPOIN1)
  841. C  Pour les autres objets DSOBJ, INIFIN=0 donc pas ecrits ?
  842.       DO i=NIOBJ-1,2,-1
  843.          DSOBJ=IPILO(i)
  844.          SEGACT DSOBJ
  845.          MO8  = LETYP
  846.          IPOI1=INIFIN
  847.          CALL ACTOBJ(MO8,IPOI1,1)
  848.          CALL ECROBJ(MO8,IPOI1)
  849.       ENDDO
  850.       GOTO 100
  851.  
  852. C  Syntaxe particuliere : CHP1 = GEO1 'MOIN' GEO2 ;
  853. C  Erreur dans le calcul du CHPOINT, incompatibilite entre les maillages
  854.  501  CONTINUE
  855.       SEGDES IPT3,IPT4
  856.  502  CONTINUE
  857.       SEGDES IPT1,IPT2
  858.       CALL ERREUR(878)
  859.       SEGSUP ICP1
  860.  
  861. C  Sortie du sousprogramme - Suppression des segments locaux
  862.  100  CONTINUE
  863.       if(IPILO.NE.0) then
  864.          DO i=1,IPILO(/1)
  865.             DSOBJ=IPILO(i)
  866.             SEGSUP DSOBJ
  867.          ENDDO
  868.          SEGSUP IPILO
  869.       ENDIF
  870.       segsup MLITY
  871.       END
  872.  
  873.  
  874.  
  875.  
  876.  
  877.  
  878.  
  879.  
  880.  
  881.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales