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

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