Télécharger la plaquette Cast3M


fr en

Télécharger manuc7.eso

Retour à la liste

Numérotation des lignes : 

manuc7

  1. C MANUC7    SOURCE    MB234859  25/09/08    21:15:51     12358          
  2.  
  3. *------------------------------------------------------------------
  4. *
  5. *                 CREATION D'UN MCHAML
  6. *
  7. *------------------------------------------------------------------
  8. *
  9. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE
  10. * -----------
  11. *
  12. *    IPMODL   (E) POINTEUR DE L'OBJET MODELE
  13. *                 MODELE et SOUS-MODELE(S) ACTIFS EN ENTREE/SORTIE
  14. *     MLMOTS  (E) POINTEUR SUR UN LISTMOTS CONTENANT LES NOMS
  15. *                 ACTIF EN ENTREE/SORTIE
  16. *     IPOI    (E) POINTEUR SUR UN LISTENTI OU UN LISTREEL
  17. *     MONMOT  (E) MOT DE 8 CARACTERES
  18. *     MLMOT3  (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES
  19. *     MLMOT2  (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES
  20. *                 DES CONSTITUANTS
  21. *     LETYP   (E) TYPE DU MCHAML A CREER
  22. *     JER1    (E) LONGUEUR DE LA CHAINE DE CARACTERES
  23. *    ISUP1    (E) SUPPORT DEMANDE
  24. *     ICHA    (S) POINTEUR SUR LE MCHAML RESULTAT
  25. *
  26. * LANGAGE:
  27. * --------
  28. *
  29. *    ESOPE + FORTRAN77
  30. *
  31. ************************************************************************
  32.  
  33.       SUBROUTINE MANUC7(IPMODL,MLMOTS,IPOI,MONMOT,MLMOT3,MLMOT2,
  34.      &                  LETYP,JER1,ISUP1,ICHA,itart)
  35.  
  36.       IMPLICIT INTEGER(I-N)
  37.       IMPLICIT REAL*8(A-H,O-Z)
  38.  
  39. -INC PPARAM
  40. -INC CCOPTIO
  41. -INC CCGEOME
  42. -INC SMCOORD
  43.  
  44. -INC SMCHAML
  45. -INC SMELEME
  46. -INC SMLMOTS
  47. -INC SMLREEL
  48. -INC SMLENTI
  49. -INC SMMODEL
  50. -INC SMINTE
  51.  
  52. -INC TMPTVAL
  53.  
  54.       SEGMENT NOTYPE
  55.         CHARACTER*16 TYPE(NBTYPE)
  56.       ENDSEGMENT
  57.  
  58.       PARAMETER ( N3 = 6 , NINF = 3 )
  59.  
  60.       CHARACTER*(*) MONMOT, LETYP
  61.  
  62.       CHARACTER*8 CHARIN
  63.       CHARACTER*(NCONCH) CONM
  64.       CHARACTER*4 CAR,CAR2
  65.  
  66.       DIMENSION INFOS(NINF)
  67.  
  68.       ICHA = 0
  69.       ITHER= 0
  70.       IDIFF= 0
  71.       IMETA= 0
  72.       ICHPH= 0
  73.  
  74.       MMODEL = IPMODL
  75.       NSOUS = mmodel.KMODEL(/1)
  76.  
  77. * Determination du nombre de sous-modeles (sous-zones) a traiter :
  78.       NSZ1 = NSOUS
  79.       DO i = 1, NSOUS
  80.         IMODEL = mmodel.KMODEL(i)
  81.         IF (imodel.NEFMOD.EQ.259) NSZ1 = NSZ1 - 1
  82.       ENDDO
  83.  
  84. *     INITIALISATION DU SEGMENT MCHELM
  85. *
  86.       N1 = NSZ1
  87.       L1 = JER1
  88.       SEGINI,MCHELM
  89.       mchelm.TITCHE = LETYP
  90.       mchelm.IFOCHE = IFOUR
  91.       N2 = mlmots.MOTS(/2)
  92.  
  93.       IF (MONMOT.EQ.'REAL*8  ') THEN
  94.         MLREEL = IPOI
  95.       ELSE
  96.         MLENTI = IPOI
  97.       ENDIF
  98.  
  99.       INFOS(1) = 0
  100.       INFOS(2) = 0
  101.       INFOS(3) = NIFOUR
  102.  
  103. * Deux petits segments utiles :
  104.       NBTYPE = 1
  105.       SEGINI,NOTYPE
  106.       TYPE(1) = ' '
  107.       MOTYBL = NOTYPE
  108.  
  109.       NBROBL = 1
  110.       NBRFAC = 0
  111.       SEGINI,NOMID
  112.       LESOBL(1) = '        '
  113.       MOTAUX = NOMID
  114. *
  115. *     BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE
  116. *
  117.       kch = 0
  118.       DO 20 isous = 1, NSOUS
  119. *
  120.         IMODEL = mmodel.KMODEL(isous)
  121. C
  122. C     ON RECUPERE L INFORMATION GENERALE
  123. C
  124.         IPMAIL =  imodel.IMAMOD
  125.         CONM   =  imodel.CONMOD
  126. C____________________________________________________________________
  127. C
  128. C     INFORMATION SUR L'ELEMENT FINI
  129. C____________________________________________________________________
  130. C
  131.         MELE = imodel.NEFMOD
  132.         IF (MELE.EQ.259) GOTO 20
  133.  
  134.         NFOR = imodel.FORMOD(/2)
  135.         CALL PLACE(imodel.FORMOD,NFOR,ITHER,'THERMIQUE')
  136.         CALL PLACE(imodel.FORMOD,NFOR,IDIFF,'DIFFUSION')
  137.         CALL PLACE(imodel.FORMOD,NFOR,IMETA,'METALLURGIE')
  138.         CALL PLACE(imodel.FORMOD,NFOR,ICHPH,'CHANGEMENT_PHASE')
  139.         CALL PLACE(imodel.FORMOD,NFOR,ICONT,'CONTACT')
  140.         CALL PLACE(imodel.FORMOD,NFOR,ICNTR,'CONTRAINTE')
  141.         CALL PLACE(imodel.FORMOD,NFOR,IDARC,'DARCY')
  142. C
  143. C      CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
  144. C
  145.         IF (IDARC.NE.0)THEN
  146.           CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  147.           CHARIN = 'MAILLAGE'
  148.           CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  149.           IF (IERR.NE.0) RETURN
  150. C* Inutile de reactiver le modele suite a LEKMOD :
  151.           IPT1  = IOBRE
  152.           IPMAIL= IOBRE
  153. c???      IF (NSZ1.GT.1) THEN
  154.           IF (NSOUS.GT.1) THEN
  155.             segact ipt1
  156.             IPMAIL = IPT1.LISOUS(isous)
  157.           ENDIF
  158.         ENDIF
  159. C Fin du cas special DARCY
  160. *
  161.         IPPORE = 0
  162.         IF (MELE.GE.79.AND.MELE.LE.83) IPPORE = NBNNE(NUMGEO(MELE))
  163.  
  164.         ISUP = ISUP1
  165.  
  166. *     EN CAS DE FORMULATION CONTACT OU CHANGEMENT_PHASE OU CONTRAINTE, SEUL SUPPORT = LES NOEUDS
  167.         IF (ICONT.NE.0 .OR.ICNTR.NE.0 .OR. ICHPH.NE.0) ISUP = 1
  168.  
  169.         IPMIN = 0
  170.         IF (ISUP.NE.1) THEN
  171.           IF (ITHER.EQ.0 .AND. IDIFF.EQ.0 .AND. IMETA.EQ.0) THEN
  172.             IPMIN = INFMOD(ISUP+2)
  173.           ELSE
  174. c           en THERMIQUE, DIFFUSION, METALLURGIE, CHANGEMENT_PHASE on veut les points de gauss ad hoc
  175.             nmat = imodel.matmod(/2)
  176.             CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  177. C           Support 6 SAUF pour le RAYONNEMENT...
  178. C           Les cas-tests de RAYONNEMENT sont en erreur sans ca...
  179.             IF (iray.EQ.0) THEN
  180.               ISUP = 6
  181.               CALL TSHAPE(MELE,'GAUSS',IPMIN)
  182.             ELSE
  183.               NLG = NUMGEO(MELE)
  184.               CALL TSHAPE(NLG,'GAUSS',IPMIN)
  185.             ENDIF
  186.           ENDIF
  187.         ENDIF
  188.         MINTE = IPMIN
  189.  
  190.         kch = kch+1
  191.         IMACHE(kch)   = IPMAIL
  192.         CONCHE(kch)   = CONMOD
  193.         INFCHE(kch,1) = 0
  194.         INFCHE(kch,2) = 0
  195.         INFCHE(kch,3) = NIFOUR
  196.         INFCHE(kch,4) = IPMIN
  197.         INFCHE(kch,5) = 0
  198.         INFCHE(kch,6) = ISUP
  199.  
  200.         SEGINI,MCHAML
  201.         ICHAML(kch) = MCHAML
  202.  
  203.         N1PTEL = 0
  204.         N1EL   = 0
  205.         N2PTEL = 0
  206.         N2EL   = 0
  207.  
  208.         IF (MONMOT.EQ.'REAL*8  ') THEN
  209.           N1PTEL = 1
  210.           N1EL   = 1
  211.           DO in = 1, N2
  212.             SEGINI,MELVAL
  213.             melval.VELCHE(N1PTEL,N1EL) = mlreel.PROG(in)
  214.             mchaml.NOMCHE(in) = mlmots.MOTS(in)
  215.             mchaml.TYPCHE(in) = MONMOT(1:6)
  216.             mchaml.IELVAL(in) = MELVAL
  217.           ENDDO
  218.  
  219.         ELSE
  220.  
  221.           DO 10 in = 1, N2
  222.             mchaml.NOMCHE(in) = mlmots.MOTS(in)
  223.             CAR  = MLMOT3.MOTS(in)(1:4)
  224.             CAR2 = MLMOT2.MOTS(in)(1:4)
  225. *
  226. *              TRAITEMENT PARTICULIER POUR LE TYPE 'MCHAML'
  227. *---------------
  228.             IF (CAR.EQ.'MCHA') THEN
  229. *
  230. *              MODIF 02/94 POUR POUTRE A FIBRES
  231. *              TEST SUR LES MAILLAGES POINTES
  232. *
  233.               IPCHE1 = mlenti.LECT(in)
  234.               MCHEL1 = IPCHE1
  235.               NSOU1 = MCHEL1.ICHAML(/1)
  236.               IDEM = 0
  237.               DO i = 1, NSOU1
  238.                 IF (IPMAIL.EQ.MCHEL1.IMACHE(i)) IDEM = 1
  239.               ENDDO
  240.               IF (IDEM.EQ.0) GO TO 295
  241. *
  242.               CALL QUESUP(IPMODL,IPCHE1,ISUP,0,IRET1,IRET2)
  243.               IF (IRET1.GT.1) THEN
  244.                 SEGSUP MCHAML
  245.                 GOTO 99
  246.               ENDIF
  247.  
  248.               nomid = MOTAUX
  249.               nomid.LESOBL(1)= mchaml.NOMCHE(in)
  250.  
  251.               CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOTAUX,MOTYBL,
  252.      $                    2,INFOS,3,IVAAUX)
  253.               IF (IERR.NE.0)THEN
  254.                 SEGSUP MCHAML
  255.                 GOTO 99
  256.               ENDIF
  257.               IF (IRET1.EQ.1) THEN
  258.                 CALL VALCHE(IVAAUX,1,IPMIN,IPPORE,MOTAUX,MELE)
  259.                 IF (IERR.NE.0) THEN
  260.                   MPTVAL = IVAAUX
  261.                   MELVA1 = IVAL(1)
  262.                   SEGSUP MPTVAL,MCHAML
  263.                   GOTO 99
  264.                 ENDIF
  265.               ENDIF
  266.               MPTVAL = IVAAUX
  267.               mchaml.TYPCHE(in) = TYVAL(1)
  268.               MELVA1 = IVAL(1)
  269.               SEGINI,MELVAL=MELVA1
  270.               IELVAL(IN) = MELVAL
  271.               IF (IRET1.EQ.1)THEN
  272.                 SEGSUP MELVA1
  273.               ENDIF
  274.               SEGSUP,MPTVAL
  275.               GOTO 10
  276.  295          CONTINUE
  277.             ENDIF
  278. *
  279.             IF (itart.EQ.1 .AND. CAR.EQ.'LIST'
  280.      $                     .AND. CAR2.EQ.'REEL') THEN
  281.               mchaml.TYPCHE(IN) = 'REAL*8  '
  282.               ipt4 = ipmail
  283.               N1EL = ipt4.num(/2)
  284.               N1PTEL = 1
  285.               N2PTEL = 0
  286.               N2EL   = 0
  287.               SEGINI,MELVAL
  288.               mlree2 = mlenti.lect(in)
  289.               jg2 = mlree2.prog(/1)
  290.               ia = 0
  291.               do i = 1, n1el
  292.                 ia = ia+1
  293.                 IF (ia.GT.jg2) ia=1
  294.                 melval.velche(N1PTEL,i) = mlree2.prog(ia)
  295.               enddo
  296.             ELSE
  297.               mchaml.TYPCHE(IN) = 'POINTEUR'//car//car2
  298.               N1PTEL = 0
  299.               N1EL   = 0
  300.               mlent2 = mlenti.lect(in)
  301.               if (ITART.EQ.1.AND.car2(1:4).eq.'INT ') then
  302.                 ipt4 = ipmail
  303.                 N2EL = ipt4.num(/2)
  304.                 N2PTEL = 1
  305.                 SEGINI,MELVAL
  306.                 jg2 = mlent2.lect(/1)
  307.                 ia = 0
  308.                 do i = 1, n2el
  309.                   ia = ia+1
  310.                   IF (ia.GT.jg2) ia=1
  311.                   melval.ielche(N2PTEL,i) = mlent2.lect(ia)
  312.                 enddo
  313.               else
  314.                 N2PTEL = 1
  315.                 N2EL   = 1
  316.                 SEGINI,MELVAL
  317.                 melval.ielche(1,1) = mlent2
  318.               endif
  319.             ENDIF
  320.             mchaml.IELVAL(IN) = MELVAL
  321.  
  322.  10       CONTINUE
  323. *         ENDDO
  324.  
  325.         ENDIF
  326.  
  327.  20   CONTINUE
  328. *     ENDDO
  329.  
  330.  99   CONTINUE
  331.  
  332.       ICHA = MCHELM
  333.       IF (IERR.NE.0) THEN
  334.         SEGSUP,MCHELM
  335.         ICHA = 0
  336.       ENDIF
  337.  
  338.       notype = MOTYBL
  339.       SEGSUP,notype
  340.       nomid = MOTAUX
  341.       SEGSUP,nomid
  342.  
  343. c      return
  344.       END
  345.  
  346.  
  347.  
  348.  

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