Télécharger la plaquette Cast3M


fr en

Télécharger mutu1.eso

Retour à la liste

Numérotation des lignes : 

mutu1

  1. C MUTU1     SOURCE    OF166741  24/10/23    21:15:02     12046          
  2.  
  3. ************************************************************************
  4. *
  5. *                             M U T U 1
  6. *                             ---------
  7. *
  8. *
  9. * FONCTION:
  10. * ---------
  11. *     CREATION DE LA MATRICE DE MUTUELLES
  12. *     GESTION DES SEGMENTS ET TESTS DE COMPATIBILITE
  13. *
  14. * PARAMETRES:  (E)=ENTREE    (S)=SORTIE   (+)=CONTENU DANS UN COMMUN
  15. * -----------
  16. *
  17. *     IPMODE   (E)  POINTEUR SUR LE SEGMENT MMODEL (ACTIF EN E/S)
  18. *     IPCHEL   (E)  POINTEUR SUR LE SEGMENT MCHELM (ACTIF EN E/S)
  19. *     IPMAIL   (E)  POINTEUR SUR LE SEGMENT MELEME S'il existe (ACTIF EN E/S)
  20. *     IPRIGI   (S)  POINTEUR SUR LE SEGMENT MRIGID
  21. *
  22. * AUTEUR, DATE DE CREATION:
  23. * -------------------------
  24. *     YANN STEPHAN, LE 28 FEVRIER 1997 (COPIE DE RESI1).
  25. *
  26. ************************************************************************
  27.  
  28.       SUBROUTINE MUTU1(IPMODE,IPCHEL,IPMAIL,IPRIGI)
  29.  
  30.       IMPLICIT INTEGER(I-N)
  31.       IMPLICIT REAL*8 (A-H,O-Z)
  32.  
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC CCHAMP
  36.  
  37. -INC SMCOORD
  38. -INC SMRIGID
  39. -INC SMCHAML
  40. -INC SMELEME
  41. -INC SMMODEL
  42.  
  43.       SEGMENT ICPR(nbpts)
  44.       SEGMENT ICPR2(nbpts)
  45.  
  46.       CHARACTER*(LOCHPO) MOTHER,MOCHAL
  47.       PARAMETER ( MOTHER='FC       ' , MOCHAL='ED       ' )
  48.  
  49.       IPRIGI = 0
  50.  
  51. * ANALYSE DU MMODEL
  52.       MMODEL = IPMODE
  53.       NBMAIM = mmodel.KMODEL(/1)
  54.  
  55. c* Cas NBMAIM = 0 a traiter
  56.       DO IM = 1, NBMAIM
  57.         IMODEL = mmodel.KMODEL(IM)
  58.         NF1 = imodel.FORMOD(/2)
  59.         CALL PLACE(imodel.FORMOD,NF1,IF1,'MAGNETODYNAMIQUE')
  60.         IF (IF1.EQ.0) THEN
  61.           CALL ERREUR(251)
  62.           RETURN
  63.         ENDIF
  64.       ENDDO
  65.  
  66. * DEFINITION DU SUPPORT DES CHAMPS : GRAVITE
  67.       ISGRAV = 2
  68.  
  69. *     VERIFICATION DU LIEU SUPPORT DU CHAMELEM DE CARACTERISTIQUES
  70. *
  71.       CALL QUESUP(IPMODE,IPCHEL,ISGRAV,0,ISUP,IRETCA)
  72.       IF (ISUP.GT.1) RETURN
  73.  
  74. * SI LE CHAMELEM EST APPUYE AUX NOEUDS, ON CHANGE LE SUPPORT
  75. * POUR LES CENTRES DE GRAVITE
  76.       IF (ISUP.EQ.1)THEN
  77.         CALL CHASUP(IPMODE,IPCHEL,IPCHE1,IRET,ISGRAV)
  78.         IF (IRET.NE.0) THEN
  79.           CALL ERREUR(IRET)
  80.           RETURN
  81.         ENDIF
  82.       ELSE
  83.         IPCHE1=IPCHEL
  84.       ENDIF
  85. *
  86. *     ACTIVATION DES SEGMENTS MCHELM ET MMODEL
  87. *
  88.       MCHELM=IPCHE1
  89. c*      SEGACT,MCHELM
  90.       NBMAIC=IMACHE(/1)
  91.  
  92. *  IL MANQUE LES CARACTERISTIQUES D'UNE OU PLUSIEURS PARTIES
  93. *  DU MODELE
  94.       IF (NBMAIM.GT.NBMAIC) THEN
  95.         CALL ERREUR(404)
  96.         GOTO 992
  97.       ENDIF
  98.  
  99.       NBMAIL=NBMAIM
  100.  
  101. * creation d'une numerotation locale dans le but de creer un
  102. * element unique support de toute la matrice de mutuelle.
  103. * on prend d'abord le maillage issu du modele puis on fait la 
  104. * meme chose pour celui issu de IPMAIL
  105.       SEGINI,ICPR
  106.       IF (IPMAIL.NE.0) SEGINI,ICPR2
  107.  
  108.       IB=0
  109.       DO IM = 1, NBMAIM
  110.         IMODEL = mmodel.KMODEL(IM)
  111.         MELEME = imodel.IMAMOD
  112.         DO I=1,NUM(/2)
  113.           DO J=1,NUM(/1)
  114.             IA = NUM(J,I)
  115.             IF (ICPR(IA).EQ.0) THEN
  116.               IB=IB+1
  117.               ICPR(IA)=IB
  118.             ENDIF
  119.           ENDDO
  120.         ENDDO
  121.       ENDDO
  122.  
  123. *  on travaille sur lui meme
  124. *   on le cree de telle facon qu'il soit identique en structure a
  125. *   celui issu du modele
  126. *
  127.       IF (IPMAIL.EQ.0) THEN
  128.         ICPR2 = ICPR
  129.         NBSOUS = NBMAIM
  130.         IF (NBSOUS.EQ.1) THEN
  131.           IMODEL = mmodel.KMODEL(1)
  132.           IPMAIL = imodel.IMAMOD
  133.         ELSE
  134.           NBREF =0
  135.           NBNN  =0
  136.           NBELEM=0
  137.           SEGINI,IPT5
  138.           DO IM = 1, NBSOUS
  139.             IMODEL = mmodel.KMODEL(IM)
  140.             IPT5.LISOUS(IM) = imodel.IMAMOD
  141.           ENDDO
  142.           IPMAIL=IPT5
  143.         ENDIF
  144.  
  145. *  on a fourni un deuxieme maillage. il faut verifier qu'il y a
  146. *  concordance topologique on boucle sur les zones de ce maillage pour
  147. *  construire une numerotation et on verifie qu'elle est compatible
  148. *  avec l'autre
  149.       ELSE
  150.         IPT1 = IPMAIL
  151.         ISM = MAX(1,IPT1.LISOUS(/1))
  152.         IF (ISM.NE.NBMAIM) THEN
  153.           CALL ERREUR(910)
  154.           GOTO 991
  155.         ENDIF
  156.         IC = 0
  157.         MELEME=IPT1
  158.         DO K = 1, ISM
  159.           IF (IPT1.LISOUS(/1).NE.0) THEN
  160.             MELEME = IPT1.LISOUS(K)
  161.           ENDIF
  162.           IMODEL = mmodel.KMODEL(K)
  163.           IPT5 = imodel.IMAMOD
  164.           IF (IPT5.NUM(/2).NE.NUM(/2))THEN
  165.             CALL ERREUR(910)
  166.             GOTO 991
  167.           ENDIF
  168.           IF (IPT5.NUM(/1).NE.NUM(/1))THEN
  169.             CALL ERREUR(910)
  170.             GOTO 991
  171.           ENDIF
  172.           DO I = 1, NUM(/2)
  173.             DO J = 1, NUM(/1)
  174.               IA = NUM(J,I)
  175.               IF (ICPR2(IA).EQ.0) THEN
  176.                 IC=IC+1
  177.                 ICPR2(IA)=IC
  178.               ENDIF
  179.               IM = ICPR(IPT5.NUM(J,I))
  180.               IF (IM.NE.ICPR2(IA)) THEN
  181.                 CALL ERREUR(910)
  182.                 GOTO 991
  183.               ENDIF
  184.             ENDDO
  185.           ENDDO
  186.         ENDDO
  187.  
  188.       ENDIF
  189.  
  190. *     INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE
  191. *
  192.       NRIGEL=1
  193.       SEGINI,MRIGID
  194.  
  195.       MTYMAT='RIGIDITE'
  196.       IFORIG=IFOUR
  197.  
  198.       COERIG(1)=1.D0
  199.       IRIGEL(1,1)=0
  200.       IRIGEL(2,1)=0
  201.       IRIGEL(3,1)=0
  202.       IRIGEL(4,1)=0
  203.       IRIGEL(5,1)=0
  204.       IRIGEL(6,1)=0
  205.       IRIGEL(7,1)=2
  206.       IRIGEL(8,1)=0
  207.  
  208.       NELRIG=1
  209.  
  210. * initialisation du maillage support de la mutuelle
  211.       NBNN  =IB
  212.       NBELEM=1
  213.       NBSOUS=0
  214.       NBREF =0
  215.       SEGINI MELEME
  216.       ITYPEL=28
  217.       DO K = 1, ICPR(/1)
  218.         IA = ICPR(K)
  219.         IF (IA.NE.0) THEN
  220.           NUM(IA,1) = K
  221.         ENDIF
  222.       ENDDO
  223.       IRIGEL(1,1)=MELEME
  224. *
  225. *  initialisation du segment descripteur
  226. *
  227.       NLIGRP=IB
  228.       NLIGRD=IB
  229.       SEGINI DESCR
  230.       SEGINI XMATRI
  231.       xmatri.symre=irigel(7,1)
  232.       DO K=1,NLIGRP
  233.         LISINC(K)=MOTHER
  234.         LISDUA(K)=MOCHAL
  235.         NOELEP(K)=K
  236.         NOELED(K)=K
  237.       ENDDO
  238.  
  239.       IRIGEL(3,1)=DESCR
  240.       IRIGEL(4,1)=XMATRI
  241.  
  242. *  Il reste a calculer les matrices (3*3 por les rot3) et
  243. *  a les assembler (l'assemblage aura lieu dans rot3M
  244.  
  245.       SEGACT,MCOORD
  246.  
  247. *     BOUCLE SUR LES MAILLAGES ELEMENTAIRES,ZONE IMAIL
  248.  
  249.       DO IM = 1, NBMAIL
  250.  
  251.          IMODEL = mmodel.KMODEL(IM)
  252.          NEF    = imodel.NEFMOD
  253.  
  254. *     CAS DE L'ELEMENT ROT3
  255.          IF (NEF.EQ.128) THEN
  256.            CALL ROT3M(NEF,IM,IMODEL,IPCHE1,IPMAIL,XMATRI,ICPR,ICPR2)
  257.  
  258. *    OPTION INDISPONIBLE
  259.          ELSE
  260.            CALL ERREUR(19)
  261.          ENDIF
  262.  
  263.          IF (IERR.NE.0) GOTO 990
  264.  
  265.       ENDDO
  266.  
  267.       IPRIGI = MRIGID
  268.  
  269.  990  CONTINUE
  270.       SEGDES,MRIGID,XMATRI
  271.       SEGDES,MCOORD
  272.  991  CONTINUE
  273.       SEGSUP,ICPR
  274.       IF (ICPR2.NE.ICPR) SEGSUP,ICPR2
  275.  992  CONTINUE
  276.       IF (ISUP.EQ.1) SEGSUP MCHELM
  277.  
  278. c      return
  279.       END
  280.  
  281.  
  282.  

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