Télécharger la plaquette Cast3M


fr en

Télécharger defo.eso

Retour à la liste

Numérotation des lignes : 

defo

  1. C DEFO      SOURCE    CB215821  23/01/25    21:15:11     11573          
  2.  
  3. ************************************************************************
  4. C  CONSTRUCTION D'UN OBJET DE TYPE DEFORME A PARTIR D'UNE GEOMETRIE
  5. C  D'UN CHPOIN UX UY UZ ET D'UN COEFFICIENT D'AMPLIFICATION
  6. C  1995 Changement de defaut de couleur P.PEGON JRC-ISPRA
  7. ************************************************************************
  8.  
  9.       SUBROUTINE DEFO
  10.  
  11.       IMPLICIT INTEGER(I-N)
  12.       IMPLICIT REAL*8(A-H,O-Z)
  13.  
  14. -INC PPARAM
  15. -INC CCOPTIO
  16. -INC CCGEOME
  17. -INC CCREEL
  18.  
  19. -INC SMCOORD
  20. -INC SMCHPOI
  21. -INC SMDEFOR
  22. -INC SMELEME
  23. -INC SMLMOTS
  24.  
  25.       CHARACTER*(LOCHPO) NOC
  26.       DIMENSION UMAX(3)
  27.  
  28. ************************************************************************
  29. *     LECTURE DES ARGUMENTS
  30. ************************************************************************
  31.  
  32. C     MAILLAGE ET CHPOINT SONT OBLIGATOIRES
  33.       CALL LIROBJ('MAILLAGE',MELEME,1,iretou)
  34.       CALL LIROBJ('CHPOINT ',MCHPOI,1,iretou)
  35.       IF (IERR.NE.0) RETURN
  36.  
  37. C     AMPLIFICATION 1 PAR DEFAUT
  38.       AMP=1.D0
  39.       CALL LIRREE(AMP,0,IRETOA)
  40.       IF (IERR.NE.0) RETURN
  41.  
  42. C     VECTEUR
  43.       MTVE=0
  44.       CALL LIROBJ('VECTEUR ',MTVE,0,iretou)
  45.       IF (IERR.NE.0) RETURN
  46.  
  47. C     COULEUR
  48.       ICOUL=0
  49.       CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  50.       IF (IERR.NE.0) RETURN
  51.       IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  52.       ICOUL=ICOUL-1
  53.  
  54.       IDIMP1 = IDIM+1
  55. ************************************************************************
  56. *     COMPOSANTES DU DEPLACEMENT SELON MODE DE CALCUL
  57. ************************************************************************
  58.       JGN = LOCHPO
  59.       JGM = IDIM
  60.       SEGINI,MLMOTS
  61.       IF      (IFOMOD.EQ.2.OR.IFOMOD.EQ.6) THEN
  62.         MLMOTS.MOTS(1) = 'UX        '
  63.         MLMOTS.MOTS(2) = 'UY        '
  64.         MLMOTS.MOTS(3) = 'UZ        '
  65.       ELSE IF (IFOMOD.EQ.-1) THEN
  66.         MLMOTS.MOTS(1) = 'UX        '
  67.         MLMOTS.MOTS(2) = 'UY        '
  68.       ELSE IF (IFOMOD.EQ.0 .OR. IFOMOD.EQ.1) THEN
  69.         MLMOTS.MOTS(1) = 'UR        '
  70.         MLMOTS.MOTS(2) = 'UZ        '
  71.       ELSE IF (IFOMOD.EQ.3) THEN
  72.         MLMOTS.MOTS(1) = 'UX        '
  73.       ELSE IF (IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN
  74.         MLMOTS.MOTS(1) = 'UR        '
  75.       ELSE
  76.         CALL ERREUR(5)
  77.         RETURN
  78.       ENDIF
  79.       IPLDEP = MLMOTS
  80.  
  81. ************************************************************************
  82. *     TRAVAIL SUR LE CHPOINT
  83. ************************************************************************
  84.       CALL REDUIR(MCHPOI,MELEME,IPCHP1)
  85.       IF (IERR.NE.0) RETURN
  86. C  VERIFICATION QU'IL Y A BIEN LES DEPLACEMENTS DANS LE CHPOINT
  87.       CALL ECROBJ('CHPOINT ',IPCHP1)
  88.       CALL ECRCHA('NOID')
  89.       CALL ECROBJ('LISTMOTS',IPLDEP)
  90.       CALL ECROBJ('LISTMOTS',IPLDEP)
  91.       IF (IERR.NE.0) RETURN
  92.       CALL EXCOMP
  93.       IF (IERR.NE.0) RETURN
  94.       CALL LIROBJ('CHPOINT ',MCHPOI,1,iretou)
  95.  
  96. ************************************************************************
  97. *     TRAVAIL SUR L'AMPLIFICATION
  98. ************************************************************************
  99.       IF (IRETOA.EQ.0) THEN
  100.  
  101.         CALL ACTOBJ('MAILLAGE',MELEME,1)
  102.         IF (IERR.NE.0) RETURN
  103.  
  104. ****    CALCUL D'UNE LONGUEUR CARACTERISTIQUE : CLONG    ****
  105. c       rem : pas besoin de CCREEL car ces valeurs seront tres vite ecrasees
  106.         XMAX=-XSGRAN
  107.         XMIN= XSGRAN
  108.         YMAX=-XSGRAN
  109.         YMIN= XSGRAN
  110.         ZMAX=-XSGRAN
  111.         ZMIN= XSGRAN
  112. *       CALCUL DU CADRE
  113.         NBSOUS=LISOUS(/1)
  114.         IPT1=MELEME
  115.  
  116.         SEGACT,MCOORD
  117.         DO ISOUS=1,MAX(1,NBSOUS)
  118.           IF (NBSOUS.NE.0) IPT1=LISOUS(ISOUS)
  119.           DO J = 1, IPT1.NUM(/2)
  120.             DO I = 1, IPT1.NUM(/1)
  121.               IREF=IDIMP1*(IPT1.NUM(I,J)-1)
  122.               XPT=XCOOR(IREF+1)
  123.               XMAX=MAX(XPT,XMAX)
  124.               XMIN=MIN(XPT,XMIN)
  125.               YPT=XCOOR(IREF+2)
  126.               YMAX=MAX(YPT,YMAX)
  127.               YMIN=MIN(YPT,YMIN)
  128.               IF (IDIM.EQ.3) THEN
  129.                 ZPT=XCOOR(IREF+3)
  130.                 ZMAX=MAX(ZPT,ZMAX)
  131.                 ZMIN=MIN(ZPT,ZMIN)
  132.               ENDIF
  133.             ENDDO
  134.           ENDDO
  135.         ENDDO
  136.         SEGDES,MCOORD
  137.         if (idim.le.2) then
  138.           ZMAX=0.D0
  139.           ZMIN=0.D0
  140.           if (idim.le.1) then
  141.             YMAX=0.D0
  142.             YMIN=0.D0
  143.           endif
  144.         endif
  145. c        CLONG=MAX(XMAX-XMIN,YMAX-YMIN,ZMAX-ZMIN)
  146. *bp,2021 : une norme 2 semble + adaptee
  147.         CLONG=SQRT((XMAX-XMIN)**2+(YMAX-YMIN)**2+(ZMAX-ZMIN)**2)
  148.  
  149. ****    CALCUL DU DEPLACEMENT MAX : UMAX    ****
  150.         UMAX(1)=0.D0
  151.         UMAX(2)=0.D0
  152.         UMAX(3)=0.D0
  153.         NSOUPO=IPCHP(/1)
  154. c  "Impossible de calculer le coefficient d'amplification"
  155.         IF (NSOUPO.EQ.0) THEN
  156.           CALL ERREUR(475)
  157.           RETURN
  158.         ENDIF
  159.         DO ISOUPO = 1, NSOUPO
  160.           MSOUPO=IPCHP(ISOUPO)
  161.           MPOVAL=IPOVAL
  162.           NC=NOCOMP(/2)
  163.           DO I = 1, NC
  164.             NOC = NOCOMP(I)
  165.             DO J = 1, IDIM
  166.               IF (NOC.EQ.MLMOTS.MOTS(J)) THEN
  167. c         Jeme composante trouvee
  168.                 DO K = 1, VPOCHA(/1)
  169.                   UMAX(J)=MAX(UMAX(J),ABS(VPOCHA(K,I)))
  170.                 ENDDO
  171.               ENDIF
  172.             ENDDO
  173.           ENDDO
  174.         ENDDO
  175.         COMPMA=SQRT(UMAX(1)**2+UMAX(2)**2+UMAX(3)**2)
  176.  
  177. *       ON PREND CLONG/(10*UMAX) COMME AMPLIFICATION
  178.         IF (COMPMA.GE.XSPETI) AMP=CLONG/(10.D0*COMPMA)
  179. c       (sinon, AMP reste = 1.d0)
  180.  
  181.       ENDIF
  182.  
  183.  
  184. ************************************************************************
  185. *     ISOVALEUR via CHPOINT ou MCHAML
  186. ************************************************************************
  187.       IPCHP1=0
  188.       IPCHEL=0
  189.       IPMODL=0
  190.       IPCHAM=0
  191. *     lecture eventuelle d'un 2nd champoint ou d'un chamelem + model
  192.       CALL LIROBJ('CHPOINT ',IPCHP1,0,iretou)
  193.       IF (IERR.NE.0) RETURN
  194.       if (iretou.eq.1) then
  195.         CALL ACTOBJ('CHPOINT ',IPCHP1,1)
  196.       else
  197.         CALL LIROBJ('MCHAML  ',IPCHEL,0,iretou)
  198.         if (ierr.ne.0) return
  199.         if (iretou.ne.0) then
  200.           CALL LIROBJ('MMODEL  ',IPMODL,1,iretou)
  201.           if (ierr.ne.0) return
  202.           CALL ACTOBJ('MCHAML  ',IPCHEL,1)
  203.           CALL ACTOBJ('MMODEL  ',IPMODL,1)
  204.           if (ierr.ne.0) return
  205. *    PASSER LES CHAMELEM AUX noeuds
  206.           CALL CHASUP(IPMODL,IPCHEL,IPCHAM,IRET,1)
  207.           IF (IRET.NE.0) THEN
  208.             CALL ERREUR(IRET)
  209.             RETURN
  210.           ENDIF
  211.         endif
  212.       endif
  213. * rem : on pourrait verifier ici que ces champs n'ont qu'une seule
  214. *       composante car TRAC ne sait pas faire autrement a ce jour
  215.  
  216. ************************************************************************
  217. *     CREATION ET ECRITURE DE LA DEFORMEE
  218. ************************************************************************
  219.       NDEF=1
  220.       SEGINI,MDEFOR
  221.       AMPL(1)  = AMP
  222.       MTVECT(1)= MTVE
  223.       IELDEF(1)= MELEME
  224.       ICHDEF(1)= MCHPOI
  225.       JCOUL(1) = ICOUL
  226.       MDCHP(1) = IPCHP1
  227.       MDMODE(1)= IPMODL
  228.       MDCHEL(1)= IPCHAM
  229.  
  230.       CALL ECROBJ('DEFORME ',MDEFOR)
  231.  
  232.       SEGSUP,MLMOTS
  233.  
  234. c      return
  235.       END
  236.  
  237.  
  238.  
  239.  
  240.  

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