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

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