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    PV090527  24/12/30    21:15:02     12108          
  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. -INC SMCOORD
  44.  
  45. -INC SMCHAML
  46. -INC SMELEME
  47. -INC SMLMOTS
  48. -INC SMLREEL
  49. -INC SMLENTI
  50. -INC SMMODEL
  51. -INC SMINTE
  52.  
  53.       SEGMENT MPTVAL
  54.         INTEGER IPOS(NS)    ,NSOF(NS)
  55.         INTEGER      IVAL(NCOSOU)
  56.         CHARACTER*16 TYVAL(NCOSOU)
  57.       ENDSEGMENT
  58.  
  59.       SEGMENT NOTYPE
  60.         CHARACTER*16 TYPE(NBTYPE)
  61.       ENDSEGMENT
  62.  
  63.       SEGMENT INFO
  64.         INTEGER INFELL(JG)
  65.       ENDSEGMENT
  66.  
  67.       PARAMETER ( N3 = 6 , NINF = 3 )
  68.  
  69.       CHARACTER*(*) MONMOT, LETYP
  70.  
  71.       CHARACTER*8 CHARIN
  72.       CHARACTER*(NCONCH) CONM
  73.       CHARACTER*4 CAR,CAR2
  74.  
  75.       DIMENSION INFOS(NINF)
  76.  
  77.       ICHA = 0
  78.       ITHER= 0
  79.       IDIFF= 0
  80.       IMETA= 0
  81.       ICHPH= 0
  82.  
  83.       MMODEL = IPMODL
  84.       NSOUS = mmodel.KMODEL(/1)
  85.  
  86. * Determination du nombre de sous-modeles (sous-zones) a traiter :
  87.       NSZ1 = NSOUS
  88.       DO i = 1, NSOUS
  89.         IMODEL = mmodel.KMODEL(i)
  90.         IF (imodel.NEFMOD.EQ.259) NSZ1 = NSZ1 - 1
  91.       ENDDO
  92.  
  93. *     INITIALISATION DU SEGMENT MCHELM
  94. *
  95.       N1 = NSZ1
  96.       L1 = JER1
  97.       SEGINI,MCHELM
  98.       mchelm.TITCHE = LETYP
  99.       mchelm.IFOCHE = IFOUR
  100.       N2 = mlmots.MOTS(/2)
  101.  
  102.       IF (MONMOT.EQ.'REAL*8  ') THEN
  103.         MLREEL = IPOI
  104.       ELSE
  105.         MLENTI = IPOI
  106.       ENDIF
  107.  
  108.       INFOS(1) = 0
  109.       INFOS(2) = 0
  110.       INFOS(3) = NIFOUR
  111.  
  112. * Deux petits segments utiles :
  113.       NBTYPE = 1
  114.       SEGINI,NOTYPE
  115.       TYPE(1) = ' '
  116.       MOTYBL = NOTYPE
  117.  
  118.       NBROBL = 1
  119.       NBRFAC = 0
  120.       SEGINI,NOMID
  121.       LESOBL(1) = '        '
  122.       MOTAUX = NOMID
  123. *
  124. *     BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE
  125. *
  126.       kch = 0
  127.       DO 20 isous = 1, NSOUS
  128. *
  129.         IMODEL = mmodel.KMODEL(isous)
  130. C
  131. C     ON RECUPERE L INFORMATION GENERALE
  132. C
  133.         IPMAIL =  imodel.IMAMOD
  134.         CONM   =  imodel.CONMOD
  135. C____________________________________________________________________
  136. C
  137. C     INFORMATION SUR L'ELEMENT FINI
  138. C____________________________________________________________________
  139. C
  140.         MELE = imodel.NEFMOD
  141.         IF (MELE.EQ.259) GOTO 20
  142.  
  143.         NFOR = imodel.FORMOD(/2)
  144.         CALL PLACE(imodel.FORMOD,NFOR,ITHER,'THERMIQUE')
  145.         CALL PLACE(imodel.FORMOD,NFOR,IDIFF,'DIFFUSION')
  146.         CALL PLACE(imodel.FORMOD,NFOR,IMETA,'METALLURGIE')
  147.         CALL PLACE(imodel.FORMOD,NFOR,ICHPH,'CHANGEMENT_PHASE')
  148.         CALL PLACE(imodel.FORMOD,NFOR,ICONT,'CONTACT')
  149.         CALL PLACE(imodel.FORMOD,NFOR,ICNTR,'CONTRAINTE')
  150.         CALL PLACE(imodel.FORMOD,NFOR,IDARC,'DARCY')
  151. C
  152. C      CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
  153. C
  154.         IF (IDARC.NE.0)THEN
  155.           CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  156.           CHARIN = 'MAILLAGE'
  157.           CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  158.           IF (IERR.NE.0) RETURN
  159. C* Inutile de reactiver le modele suite a LEKMOD :
  160.           IPT1  = IOBRE
  161.           IPMAIL= IOBRE
  162. c???      IF (NSZ1.GT.1) THEN
  163.           IF (NSOUS.GT.1) THEN
  164.             segact ipt1
  165.             IPMAIL = IPT1.LISOUS(isous)
  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.         info  = 0
  180.         IF (ISUP.NE.1) THEN
  181.           IF (ITHER.EQ.0 .AND. IDIFF.EQ.0 .AND. IMETA.EQ.0) THEN
  182.             IF (2+ISUP.GT.infmod(/1)) THEN
  183.               CALL ELQUOI(MELE,0,ISUP,IPINF,IMODEL)
  184.               IF (IERR.NE.0) GOTO 99
  185.               info  = IPINF
  186.               IPMIN = info.INFELL(11)
  187.               SEGSUP,info
  188.             else
  189.               IPMIN = infmod(ISUP+2)
  190.             endif
  191.           ELSE
  192. c           en THERMIQUE, DIFFUSION, METALLURGIE, CHANGEMENT_PHASE on veut les points de gauss ad hoc
  193.             nmat = imodel.matmod(/2)
  194.             CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  195. C           Support 6 SAUF pour le RAYONNEMENT...
  196. C           Les cas-tests de RAYONNEMENT sont en erreur sans ca...
  197.             IF (iray.EQ.0) THEN
  198.               ISUP = 6
  199.               CALL TSHAPE(MELE,'GAUSS',IPMIN)
  200.             ELSE
  201.               NLG = NUMGEO(MELE)
  202.               CALL TSHAPE(NLG,'GAUSS',IPMIN)
  203.             ENDIF
  204.           ENDIF
  205.         ENDIF
  206.         MINTE = IPMIN
  207.  
  208.         kch = kch+1
  209.         IMACHE(kch)   = IPMAIL
  210.         CONCHE(kch)   = CONMOD
  211.         INFCHE(kch,1) = 0
  212.         INFCHE(kch,2) = 0
  213.         INFCHE(kch,3) = NIFOUR
  214.         INFCHE(kch,4) = IPMIN
  215.         INFCHE(kch,5) = 0
  216.         INFCHE(kch,6) = ISUP
  217.  
  218.         SEGINI,MCHAML
  219.         ICHAML(kch) = MCHAML
  220.  
  221.         N1PTEL = 0
  222.         N1EL   = 0
  223.         N2PTEL = 0
  224.         N2EL   = 0
  225.  
  226.         IF (MONMOT.EQ.'REAL*8  ') THEN
  227.           N1PTEL = 1
  228.           N1EL   = 1
  229.           DO in = 1, N2
  230.             SEGINI,MELVAL
  231.             melval.VELCHE(N1PTEL,N1EL) = mlreel.PROG(in)
  232.             mchaml.NOMCHE(in) = mlmots.MOTS(in)
  233.             mchaml.TYPCHE(in) = MONMOT(1:6)
  234.             mchaml.IELVAL(in) = MELVAL
  235.           ENDDO
  236.  
  237.         ELSE
  238.  
  239.           DO 10 in = 1, N2
  240.             mchaml.NOMCHE(in) = mlmots.MOTS(in)
  241.             CAR  = MLMOT3.MOTS(in)(1:4)
  242.             CAR2 = MLMOT2.MOTS(in)(1:4)
  243. *
  244. *              TRAITEMENT PARTICULIER POUR LE TYPE 'MCHAML'
  245. *---------------
  246.             IF (CAR.EQ.'MCHA') THEN
  247. *
  248. *              MODIF 02/94 POUR POUTRE A FIBRES
  249. *              TEST SUR LES MAILLAGES POINTES
  250. *
  251.               IPCHE1 = mlenti.LECT(in)
  252.               MCHEL1 = IPCHE1
  253.               NSOU1 = MCHEL1.ICHAML(/1)
  254.               IDEM = 0
  255.               DO i = 1, NSOU1
  256.                 IF (IPMAIL.EQ.MCHEL1.IMACHE(i)) IDEM = 1
  257.               ENDDO
  258.               IF (IDEM.EQ.0) GO TO 295
  259. *
  260.               CALL QUESUP(IPMODL,IPCHE1,ISUP,0,IRET1,IRET2)
  261.               IF (IRET1.GT.1) THEN
  262.                 SEGSUP MCHAML
  263.                 GOTO 99
  264.               ENDIF
  265.  
  266.               nomid = MOTAUX
  267.               nomid.LESOBL(1)= mchaml.NOMCHE(in)
  268.  
  269.               CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOTAUX,MOTYBL,
  270.      $                    2,INFOS,3,IVAAUX)
  271.               IF (IERR.NE.0)THEN
  272.                 SEGSUP MCHAML
  273.                 GOTO 99
  274.               ENDIF
  275.               IF (IRET1.EQ.1) THEN
  276.                 CALL VALCHE(IVAAUX,1,IPMIN,IPPORE,MOTAUX,MELE)
  277.                 IF (IERR.NE.0) THEN
  278.                   MPTVAL = IVAAUX
  279.                   MELVA1 = IVAL(1)
  280.                   SEGSUP MPTVAL,MCHAML
  281.                   GOTO 99
  282.                 ENDIF
  283.               ENDIF
  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.       ICHA = MCHELM
  351.       IF (IERR.NE.0) THEN
  352.         SEGSUP,MCHELM
  353.         ICHA = 0
  354.       ENDIF
  355.  
  356.       notype = MOTYBL
  357.       SEGSUP,notype
  358.       nomid = MOTAUX
  359.       SEGSUP,nomid
  360.  
  361. c      return
  362.       END
  363.  
  364.  
  365.  
  366.  

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