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

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