Télécharger la plaquette Cast3M


fr en

Télécharger exelch.eso

Retour à la liste

Numérotation des lignes : 

exelch

  1. C EXELCH    SOURCE    PV090527  23/02/02    23:09:15     11579          
  2. *
  3. *   EXTRAIRE LE OU LES ELEMENTS SUPPORTS DU MAXI OU DU MINI DES VALEURS
  4. *   COMPOSANTES D'UN CHAMP/ELEMENT
  5. *
  6. ************************************************************************
  7. *   ENTREES :
  8. *
  9. *     IPCHEL =POINTEUR SUR UN MCHAML
  10. *     IMM    = 1  MAXI , 2 MINI , 3 A 9  LES AUTRES
  11. *     IAB    = 0 VALEURS ALGEBRIQUES  ,1 VALEURS ABSOLUES
  12. *     IAV    = 1 LES NOMS DE LA LISTMOTS SONT CONSIDERES,
  13. *              2 ILS SONT EXCLUS
  14. *     ILAST  = 1 STRICTEMENT (Tous les PTS de Gauss doivent respecter la condition)
  15. *            = 2 LARGEMENT   (Un seul  PT  de Gauss doit    respecter la condition)
  16. *     IPLIS  = POINTEUR SUR UN LISTMOTS
  17. *     VALREF = VALEUR POUR FAIRE LES COMPARAISONS
  18. *     VALRE2 = IDEM  POUR OPTION  'COMPRIS'
  19. *
  20. *    SORTIES :
  21. *
  22. *    IPMAIL  = POINTEUR  SUR OBJET MAILLAGE CONTENANT LE OU LES ELEMENTS
  23. *              SUPPORTS DU MAXI OU DU MINI OU SATISFAISANT LES TESTS
  24. *              PAR RAPPORT A VALREF
  25. *
  26. *  P DOWLATYARI OCT 91
  27. ************************************************************************
  28.       SUBROUTINE EXELCH(IPCHEL,IMM,IAB,IAV,ILAST,IPLIS,VALREF,VALRE2,
  29.      &                  IPMAIL)
  30.  
  31.       IMPLICIT INTEGER(I-N)
  32.       IMPLICIT REAL*8(A-H,O-Z)
  33.  
  34.  
  35. -INC PPARAM
  36. -INC CCOPTIO
  37. -INC CCREEL
  38.  
  39. -INC SMCHAML
  40. -INC SMELEME
  41. -INC SMLMOTS
  42.  
  43.       SEGMENT QUELCO
  44.         INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS),IMEL(NSOUS)
  45.       ENDSEGMENT
  46.  
  47.       SEGMENT MMEL
  48.         INTEGER NELC,LELC(NBELC)
  49.       ENDSEGMENT
  50.  
  51.       SEGMENT MESH
  52.         INTEGER LMAIL(NMAIL,3+NSOUS)
  53.       ENDSEGMENT
  54.  
  55.       LOGICAL BOOL1
  56.       CHARACTER*(LOCOMP) MOCOMP
  57.       logical suffi
  58.  
  59. *  INITIALISATIONS
  60.       suffi=.false.
  61.       IPMAIL = 0
  62. *
  63.       IMAIL  = 0
  64.       QUELCO = 0
  65.       MESH   = 0
  66.  
  67. * VERIFICATIONS D'USAGE (normalement inutiles) :
  68.       IF (IMM.LT.1 .OR. IMM.GT.9) THEN
  69.         write(ioimp,*) 'EXELCH IMM =',IMM
  70.         CALL ERREUR(5)
  71.         RETURN
  72.       ENDIF
  73.       IF (IAB.LT.0 .OR. IAB.GT.1) THEN
  74.         write(ioimp,*) 'EXELCH IAB =',IAB
  75.         CALL ERREUR(5)
  76.         RETURN
  77.       ENDIF
  78.       IF (IAV.LT.1 .OR. IAV.GT.2) THEN
  79.         write(ioimp,*) 'EXELCH IAV =',IAV
  80.         CALL ERREUR(5)
  81.         RETURN
  82.       ENDIF
  83.       IF (ILAST.LT.1 .OR. ILAST.GT.2) THEN
  84.         write(ioimp,*) 'EXELCH ILAST =',ILAST
  85.         CALL ERREUR(5)
  86.         RETURN
  87.       ENDIF
  88.  
  89. * ON RECUPERE LE CHAMP PAR ELEMENT
  90. *
  91.       MCHELM = IPCHEL
  92.       SEGACT,MCHELM
  93.       NSOUS = mchelm.IMACHE(/1)
  94. * MCHAML vide -> Maillage vide en sortie
  95.       IF (NSOUS.EQ.0) GOTO 90
  96.  
  97. *  ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES
  98. *
  99.       NCOMX  = 0
  100.       DO 10 ISOUS = 1, NSOUS
  101.         mchaml = mchelm.ICHAML(ISOUS)
  102.         SEGACT,mchaml
  103.         NCOMX = MAX(NCOMX,mchaml.NOMCHE(/2))
  104.  10   CONTINUE
  105. * MCHAML sans composante -> Maillage vide en sortie
  106.       IF (NCOMX.EQ.0) GOTO 90
  107.       SEGINI,QUELCO
  108.  
  109. * Remplissage de QUELCO qui indique les composantes a prendre en compte
  110. * sur chaque sous-zone
  111. * Par defaut, on prend toutes les composantes, sauf si la listmots est 
  112. * fournie, et dans ce cas, on conserve ou on exclut les composantes.
  113. *
  114.       IF (IPLIS.NE.0) THEN
  115.         mlmots = IPLIS
  116.         SEGACT,mlmots
  117.         NCLIS = mlmots.MOTS(/2)
  118.       ENDIF
  119.  
  120.       NZERO = NSOUS
  121.       DO 20 ISOUS = 1, NSOUS
  122.         MELEME = mchelm.IMACHE(ISOUS)
  123.         MCHAML = mchelm.ICHAML(ISOUS)
  124.         NCOMP  = mchaml.NOMCHE(/2)
  125.         IF (IPLIS.EQ.0) THEN
  126.           DO ICOMP = 1, NCOMP
  127.             quelco.ICO(ISOUS,ICOMP) = 1
  128.           ENDDO
  129.           NCO = NCOMP
  130.         ELSE
  131.           NCO = 0
  132.           DO ICOMP = 1, NCOMP
  133.             MOCOMP = mchaml.NOMCHE(ICOMP)
  134.             CALL PLACE(mlmots.MOTS,NCLIS,IX,MOCOMP)
  135.             igco = 0
  136.             IF (IAV.EQ.1) THEN
  137.               IF (IX.NE.0) igco = 1
  138.             ELSE
  139.               IF (IX.EQ.0) igco = 1
  140.             ENDIF
  141.             quelco.ICO(ISOUS,ICOMP) = igco
  142.             NCO = NCO + igco
  143.           ENDDO
  144.         ENDIF
  145.         quelco.NNCO(ISOUS) = NCO
  146.         IF (NCO.NE.0) THEN
  147. c* On verifie si MELEME n'a pas deja ete rencontre dans les sous-zones 
  148. c* precedentes...
  149.           mmel = 0
  150.           DO ISZ = ISOUS-1, 1, -1
  151.             IF (meleme.EQ.mchelm.IMACHE(ISZ)) THEN
  152.               mmel = -ABS(quelco.IMEL(ISZ))
  153.             ENDIF
  154.           ENDDO
  155.           IF (mmel.EQ.0) THEN
  156.             SEGACT,meleme
  157.             NBELC = meleme.NUM(/2)
  158.             SEGINI,mmel
  159.           ENDIF
  160.         ELSE
  161.           mmel = 0
  162.           NZERO = NZERO - 1
  163.         ENDIF
  164.         quelco.IMEL(ISOUS) = mmel
  165.  20   CONTINUE
  166.  
  167. * Cas particulier ou aucune composante n'est a traiter -> Maillage Vide
  168.       IF (NZERO.EQ.0) GOTO 90
  169.  
  170. *  RECHERCHE DU MAXI OU MINI ( IMM = 1 OU 2 )
  171. *
  172.       IF (IMM.LE.2) THEN
  173.         IF (IMM.EQ.1) THEN
  174.           IF (IAB.EQ.0) THEN
  175.             XEXT = -XGRAND
  176.           ELSE
  177.             XEXT = XZERO
  178.           ENDIF
  179.         ELSE
  180.           XEXT = XGRAND
  181.         ENDIF
  182.  
  183.         DO 30 ISOUS = 1, NSOUS
  184.           IF (quelco.NNCO(ISOUS).EQ.0) GOTO 30
  185.           MCHAML = mchelm.ICHAML(ISOUS)
  186.           NCOMP  = mchaml.NOMCHE(/2)
  187.           DO 310 ICOMP = 1, NCOMP
  188.             IF (quelco.ICO(ISOUS,ICOMP).EQ.0) GOTO 310
  189.             melval = mchaml.IELVAL(ICOMP)
  190.             SEGACT,melval
  191.             NBPTEL = melval.VELCHE(/1)
  192.             NEL    = melval.VELCHE(/2)
  193.             DO IB = 1, NEL
  194.               DO IGAU = 1,NBPTEL
  195.                 XX = melval.VELCHE(IGAU,IB)
  196.                 IF (IAB.EQ.1) XX = ABS(XX)
  197.                 IF (IMM.EQ.1) THEN
  198.                   XEXT = MAX(XX,XEXT)
  199.                 ELSE
  200.                   XEXT = MIN(XX,XEXT)
  201.                 ENDIF
  202.               ENDDO
  203.             ENDDO
  204.  310      CONTINUE
  205.  30     CONTINUE
  206.       ENDIF
  207.  
  208. *  BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS
  209. *
  210.       DO 40 ISOUS = 1, NSOUS
  211.         IF (quelco.NNCO(ISOUS).EQ.0) GOTO 40
  212.         mmel = ABS(quelco.IMEL(ISOUS))
  213. *        segact,mmel
  214.         NBELC = mmel.LELC(/1)
  215. c* Si NELC = NBELC c'est que tous les elements du maillage sont deja 
  216. c* pris auparavant (meleme commun a plusieurs sous-zones) donc on 
  217. c* ne poursuit plus le traitement pour cette sous-zone...
  218.         IF (mmel.NELC.EQ.NBELC) GOTO 40
  219.         MCHAML = mchelm.ICHAML(ISOUS)
  220.         NCOMP  = mchaml.NOMCHE(/2)
  221.         DO 410 ICOMP = 1, NCOMP
  222.           IF (quelco.ICO(ISOUS,ICOMP).EQ.0) GOTO 410
  223. c* Si NELC = NBELC c'est que tous les elements sont deja pris pour 
  224. c* les precedentes composantes de cette sous-zone...
  225.           IF (mmel.NELC.EQ.NBELC) GOTO 40
  226.           melval = mchaml.IELVAL(ICOMP)
  227.           SEGACT,melval
  228.           NBPTEL = melval.VELCHE(/1)
  229.           NEL    = melval.VELCHE(/2)
  230. c* Normalement : NEL = 1 ou NEL = NBELC (a verifier ?)
  231.           DO 420 IB = 1, NBELC
  232. C* Si l'element a deja ete retenu, ce n'est pas la peine de continuer...
  233.             IF (mmel.LELC(IB).EQ.1) GOTO 420
  234. * si mini/maxi strict un element suffit
  235.             if (suffi) goto 420
  236.             IBMN = MIN(IB,NEL)
  237.             igco = 0
  238.             DO 430 IGAU = 1, NBPTEL
  239.               XX = melval.VELCHE(IGAU,IBMN)
  240.               IF (IAB.EQ.1) XX = ABS(XX)
  241.  
  242. *  TRI SELON LA VALEUR DE IMM
  243.               GOTO (21,21,23,24,25,26,27,28,29),IMM
  244. c* Erreur ne devant pas arriver normalement (voir test au debut)
  245.               CALL ERREUR(5)
  246.               GOTO 9000
  247.  
  248. *          MAXI OU MINI
  249.   21          BOOL1 = (XX.EQ.XEXT)
  250.               GOTO 425
  251. *          SUPE
  252.   23          BOOL1 = (XX.GT.VALREF)
  253.               GOTO 425
  254. *          EGSUPE
  255.   24          BOOL1 = (XX.GE.VALREF)
  256.               GOTO 425
  257. *          EGAL
  258.   25          BOOL1 = (XX.EQ.VALREF)
  259.               GOTO 425
  260. *          EGINFE
  261.   26          BOOL1 = (XX.LE.VALREF)
  262.               GOTO 425
  263. *          INFE
  264.   27          BOOL1 = (XX.LT.VALREF)
  265.               GOTO 425
  266. *          DIFF
  267.   28          BOOL1 = (XX.NE.VALREF)
  268.               GOTO 425
  269. *          COMP
  270.   29          BOOL1 = (XX.GE.VALREF) .AND. (XX.LE.VALRE2)
  271.               GOTO 425
  272. *
  273.  425          CONTINUE
  274.               IF (BOOL1) THEN
  275. *  si strict et mini ou maxi, on ne rend qu'un seul element
  276.                 if (imm.le.2.and.ilast.eq.1) suffi = .true. 
  277.                 igco = igco + 1
  278. C              On prend l'element au premier rencontre car LARG
  279.                 IF (ILAST.EQ.2.or.suffi) GOTO 435
  280.               ELSE
  281. C              On change d''element si 'STRI'
  282.                 IF (ILAST.EQ.1.and.imm.gt.2) GOTO 420
  283.               ENDIF
  284.  430        CONTINUE
  285.  435        IF (igco.GT.0) THEN
  286.               mmel.LELC(IB) = 1
  287.               mmel.NELC = mmel.NELC + 1
  288.             ENDIF
  289.  420      CONTINUE
  290.  410    CONTINUE
  291.  40   CONTINUE
  292.  41   CONTINUE
  293.  
  294. C* Il faut maintenant construire le maillage correspondant :
  295.       NMAIL = NSOUS
  296.       SEGINI,MESH
  297.       IMAIL = 0
  298.       DO 500 ISOUS = 1, NSOUS
  299.         mmel = quelco.IMEL(ISOUS)
  300.         IF (mmel.LE.0) GOTO 500
  301. *        segact,mmel
  302.         IF (mmel.NELC.EQ.0) GOTO 500
  303.         ipt1 = mchelm.IMACHE(ISOUS)
  304. *        segact,ipt1
  305.         ity1 = ipt1.ITYPEL
  306.         nbn1 = ipt1.NUM(/1)
  307.         DO im = 1, IMAIL
  308.           IF (ity1.EQ.mesh.LMAIL(im,1) .AND.
  309.      &        nbn1.EQ.mesh.LMAIL(im,2)) THEN
  310. C* Le 2e test sert dans le cas particulier des elements SURE pour 
  311. C* lesquels itypel=48 mais le nombre de noeuds variables !
  312.             IMSH = im
  313.             GOTO 510
  314.           ENDIF
  315.         ENDDO
  316.         IMAIL = IMAIL + 1
  317.         IMSH = IMAIL
  318.         mesh.LMAIL(IMSH,1) = ity1
  319.         mesh.LMAIL(IMSH,2) = nbn1
  320.         mesh.LMAIL(IMSH,3) = 0
  321.  510    CONTINUE
  322.         mesh.LMAIL(IMSH,3+ISOUS) = mesh.LMAIL(IMSH,3) + 1
  323.         mesh.LMAIL(IMSH,3) = mesh.LMAIL(IMSH,3) + mmel.NELC
  324.  500  CONTINUE
  325. *
  326. * Cas particulier : le maillage resultat est vide
  327.  90   CONTINUE
  328.       IF (IMAIL.EQ.0) THEN
  329.         NBNN   = 0
  330.         NBELEM = 0
  331.         NBSOUS = 0
  332.         NBREF  = 0
  333.         SEGINI,meleme
  334.         meleme.ITYPEL = 0
  335.       ELSE
  336.         IF (IMAIL.GT.1)THEN
  337.           NBNN   = 0
  338.           NBELEM = 0
  339.           NBSOUS = IMAIL
  340.           NBREF  = 0
  341.           SEGINI,meleme
  342.         ENDIF
  343.         DO 600 IMSH = 1, IMAIL
  344.           NBNN   = mesh.LMAIL(IMSH,2)
  345.           NBELEM = mesh.LMAIL(IMSH,3)
  346.           NBSOUS = 0
  347.           NBREF  = 0
  348.           SEGINI,ipt3
  349.           ipt3.ITYPEL = mesh.LMAIL(IMSH,1)
  350.           js = 0
  351.           jm = 0
  352.           DO 610 ISOUS = 1, NSOUS
  353.             im = mesh.LMAIL(IMSH,3+ISOUS)
  354.             IF (im.EQ.0) GOTO 610
  355.             im = im - 1
  356.             ipt2 = mchelm.IMACHE(ISOUS)
  357.             NBEL2 = ipt2.NUM(/2)
  358.             mmel = quelco.IMEL(ISOUS)
  359. c* Quelques tests de verification/debogage au cas ou :
  360.        if (mmel.LE.0) then
  361.          write(ioimp,*) 'exelch : err 610 mmel',mmel,isous,imsh
  362.          call erreur(5)
  363.        endif
  364.        nbnn2 = ipt2.NUM(/1)
  365.        if (nbnn2.NE.nbnn) then
  366.          write(ioimp,*) 'exelch : err 610 nbnn',nbnn2,nbnn,isous,imsh
  367.          call erreur(5)
  368.        endif
  369.        nbelc = mmel.LELC(/1)
  370.        if (NBEL2.NE.nbelc) then
  371.          write(ioimp,*) 'exelch : err 610 nbel',nbelc,nbel2,isous,imsh
  372.          call erreur(5)
  373.        endif
  374.             js = js + 1
  375.             DO 620 IB = 1, NBEL2
  376.               IF (mmel.LELC(IB).EQ.0) GOTO 620
  377.               im = im + 1
  378.               jm = jm + 1
  379.               DO igau = 1, NBNN
  380.                 ipt3.NUM(igau,im) = ipt2.NUM(igau,IB)
  381.               ENDDO
  382.               ipt3.ICOLOR(im) = ipt2.ICOLOR(IB)
  383.  620        CONTINUE
  384.  610      CONTINUE
  385.       if (jm.ne.NBELEM) then
  386.         write(ioimp,*) 'exelch : incoherence jm',jm,nbelem,imsh
  387.         call erreur(5)
  388.       endif
  389.           IF (js.GT.1) THEN
  390.             iordre=0
  391.             CALL UNIQM1(ipt3,ipt1,nbdif,iordre)
  392.             IF (IPT1.NE.IPT3) SEGSUP,ipt3
  393. c*            if (ipt1.eq.0) then
  394. c*              write(ioimp,*) 'exelch : maillage vide',imsh
  395. c*            endif
  396.           ELSE
  397.             ipt1 = ipt3
  398.           ENDIF
  399.           IF (IMAIL.GT.1) THEN
  400.             meleme.LISOUS(IMSH) = ipt1
  401.           ENDIF
  402.  600    CONTINUE
  403.         IF (IMAIL.EQ.1) meleme = ipt1
  404.       ENDIF
  405.       IPMAIL = meleme
  406.       IF (mesh.NE.0) SEGSUP,mesh
  407.  
  408.  9000 CONTINUE
  409.       DO ISOUS = 1, NSOUS
  410.         meleme = mchelm.IMACHE(ISOUS)
  411.         mchaml = mchelm.ICHAML(ISOUS)
  412.         mmel = quelco.IMEL(ISOUS)
  413.         IF (mmel.GT.0) SEGSUP,mmel
  414.       ENDDO
  415.       IF (quelco.NE.0) SEGSUP,quelco
  416.  
  417.       END
  418.  
  419.  
  420.  
  421.  
  422.  

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