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

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