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

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