Télécharger la plaquette Cast3M


fr en

Télécharger combil.eso

Retour à la liste

Numérotation des lignes : 

combil

  1. C COMBIL    SOURCE    PV        22/07/28    21:15:02     11419          
  2.  
  3.       SUBROUTINE COMBIL(ITACH,ITAFL,NCH,IRETT)
  4.  
  5. C----------------------------------------------------------------------
  6. C    CE SUBROUTINE EFFECTUE LA COMBINAISON LINEAIRE DES NCH CHPOINT
  7. C    CONTENUS DANS ITACH, AVEC LES NCH FLOTTANTS CONTENUS DANS ITAFL
  8. C    LE RESULTAT EST UN CHPOINT,MIS DANS IRETT
  9. C    ATTENTION : TAFL EN DOUBLE PRECISION
  10. c    BP, 2015-06-26 : segments actifs en E/S
  11. c    BP, 2017-12-14 : changement de methode inspire de funobj
  12. C----------------------------------------------------------------------
  13.  
  14.       IMPLICIT INTEGER(I-N)
  15.       IMPLICIT REAL*8 (A-H,O-Z)
  16.  
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC SMCOORD
  21. -INC SMCHPOI
  22. -INC TMTRAV
  23. -INC SMELEME
  24.  
  25. c     SEGMENTS D'ENTREE :
  26.       SEGMENT ITACH(0)
  27.       SEGMENT/ITAFL/(TAFL(0)*D)
  28.  
  29. C     ITRAV : SEGMENT DE TRAVAIL POUR CRECHP
  30.       SEGMENT ITRAV
  31.         CHARACTER*(LOCOMP) INC (NN)
  32.         INTEGER     IHAR(NN)
  33.       ENDSEGMENT
  34.  
  35. C     ICPR(#global) = #local
  36.       SEGMENT ICPR(nbpts)
  37.  
  38. C     IZON1(#local) = indice de la zone a laquelle appartient ce noeud
  39.       SEGMENT IZON1(NZON1)
  40.  
  41. c     IIPT1(indice de zone) = maillage support definissant cette zone
  42.       SEGMENT IIPT1(NIPT1)
  43.  
  44. c     IELEM(#local)=#element de IPT1
  45.       SEGMENT IELEM(NZON1)
  46.  
  47.       SEGMENT MICOM(NCOM)
  48.  
  49.       CHARACTER*8 CHA8,CHA8a,CHA8b
  50.       REAL*8  VAL
  51. C
  52.       IRETT=0
  53.  
  54.       IF(NCH.GT.0) GOTO 1
  55. C----------------------------------------------------------------------
  56. C     METHODE POUR NCH=0 
  57. C     --> on renvoie un chpoint vide
  58. C----------------------------------------------------------------------
  59.       NAT=1
  60.       NSOUPO=0
  61.       SEGINI,MCHPOI
  62.       IFOPOI=IFOUR
  63.       MTYPOI   = ' '
  64.       MOCHDE   = ' '      
  65.       JATTRI(1)=  0
  66.       IRETT=MCHPOI
  67.       RETURN
  68.  
  69.  1    CONTINUE
  70.       IF(NCH.GT.1) GOTO 2
  71. C----------------------------------------------------------------------
  72. C     METHODE POUR NCH=1
  73. C----------------------------------------------------------------------
  74.       ICHPO=ITACH(1)
  75.       VAL=TAFL(1)
  76.       CALL MUCHPO(ICHPO,VAL,IRETT,1)
  77.       RETURN
  78.  
  79.  2    CONTINUE
  80.       IF(NCH.GT.2) GOTO 3
  81. C----------------------------------------------------------------------
  82. C     METHODE POUR NCH=2
  83. C----------------------------------------------------------------------
  84.       ICHPO1=ITACH(1)
  85.       ICHPO2=ITACH(2)
  86.       VAL1=TAFL(1)
  87.       VAL2=TAFL(2)
  88.       CALL ADCHPO(ICHPO1,ICHPO2,IRETT,VAL1,VAL2)
  89.       RETURN
  90.  
  91.  3    CONTINUE
  92. C----------------------------------------------------------------------
  93. C     METHODEs POUR NCH>2 :
  94. c     addition de CHPOINT en une seule fois (Pas de CHPOINT temporaires)
  95. c     - methode RAPIDE : evite la partition de la geometrie
  96. c                        (inspiree de adchpo.eso)
  97. c     - methode GENERALE : pas d'hypothese sur les supports
  98. c                          (inspiree de funobj.eso)
  99. C----------------------------------------------------------------------
  100.  
  101. c     INITIALISATIONS
  102.       NN    = 0
  103.       NNIN  = 0
  104.       NNNOE = 0
  105.       NAT   =  1
  106.       NATi  = -1
  107.       NATf  = -1
  108.       CHA8  = '        '
  109.       CHA8a = '        '
  110.       CHA8b = '        '
  111.       SEGACT,MCOORD
  112.       SEGINI,ICPR
  113.       NLOC  = 0
  114.       NIPT1 = 0
  115.       NCOM  = 0
  116.  
  117. C---- OUVERTURE DE TOUS LES MCHPOI ----
  118.       DO 400 III = 1,NCH
  119.         MCHPOI = ITACH(III)
  120.         SEGACT,MCHPOI
  121.         NSOUPO = MCHPOI.IPCHP(/1)
  122.         NAT    = MAX(NAT,MCHPOI.JATTRI(/1))
  123.         NATi   = MCHPOI.JATTRI(1)
  124.         CHA8   = MCHPOI.MTYPOI 
  125.         IF(III .EQ. 1) THEN
  126.           NATf = NATi
  127.           CHA8a=CHA8
  128.           CHA8b=CHA8
  129.         ELSE
  130.           IF (NATi .NE. NATf) THEN
  131.             NATf=0
  132.           ENDIF
  133.           IF (CHA8 .NE. CHA8a) THEN
  134.             CHA8b='INDETERM'
  135.           ENDIF
  136.         ENDIF
  137.         NIPT1=NIPT1+NSOUPO
  138.         DO 401 JJJ = 1,NSOUPO
  139. C         Ouverture de tous les MSOUPO
  140.           MSOUPO = MCHPOI.IPCHP(JJJ)
  141.           SEGACT,MSOUPO
  142.           NC=MSOUPO.NOHARM(/1)
  143.           NN=NN+NC
  144.           NCOM=MAX(NCOM,NC)
  145.  
  146. c     +++ on regarde si on peut eviter de partitionner la geometrie +++
  147. c         (remplissage de ICPR et IZON)
  148.           MELEME=IGEOC
  149.           SEGACT,MELEME
  150.           DO 402 IEL=1,NUM(/2)
  151.             INUM=NUM(1,IEL)
  152.             ILOC=ICPR(INUM)
  153. c           si noeud jamais vu : on l'ajoute a ICPR
  154.             IF(ILOC.EQ.0) THEN
  155.               NLOC=NLOC+1
  156.               ILOC=NLOC
  157.               ICPR(INUM)=ILOC
  158.             ENDIF
  159. c           IZON(indice chpoint,#local car trop gros sinon)=indice de zone
  160. c             IZON(III,ILOC)=JJJ
  161.  402      CONTINUE
  162.  
  163.  401    CONTINUE
  164.  400  CONTINUE
  165.  
  166. c +++ on regarde si on peut eviter de partitionner la geometrie +++
  167.       NZON1=NLOC
  168.       SEGINI,IZON1,IIPT1
  169.       IBMAX=0
  170.       DO 410 III = 1,NCH
  171.         MCHPOI = ITACH(III)
  172.         NSOUPO = MCHPOI.IPCHP(/1)
  173.         DO 411 JJJ = 1,NSOUPO
  174.           MSOUPO = MCHPOI.IPCHP(JJJ)
  175.           MELEME = IGEOC
  176.           INUM11=NUM(1,1)
  177.           ILOC11=ICPR(INUM11)
  178. c         quelle zone du chpoint final est associee a ce noeud ?
  179.           IB = IZON1(ILOC11)
  180.           IF(IB.EQ.0) THEN
  181. c           on verifie bien qu'on a jamais vu aucun noeud de ce maillage
  182.             IBMAX=IBMAX+1
  183.             DO 412 IEL=1,NUM(/2)
  184.               INUM=NUM(1,IEL)
  185.               ILOC=ICPR(INUM)
  186.               IF(IZON1(ILOC).NE.IB) GOTO 419
  187.               IZON1(ILOC)=IBMAX
  188.  412        CONTINUE
  189. c           ici, tous les noeuds de MELEME appartiennent a la zone IB=0
  190. c           il faut ajouter MELEME dans IIPT1 (+ noeuds dans IZON1)
  191.             IIPT1(IBMAX)=MELEME
  192.           ELSE
  193. c           on verifie bien qu'il s'agit bien du meme maillage
  194.             IPT1=IIPT1(IB)
  195.             IF(MELEME.EQ.IPT1) GOTO 411
  196.             IF(NUM(/2).NE.IPT1.NUM(/1)) GOTO 419
  197. c           il faut verifier que tous les noeuds sont dans la zone IB
  198.             DO 413 IEL=1,NUM(/2)
  199.               INUM=NUM(1,IEL)
  200.               ILOC=ICPR(INUM)
  201.               IF(IZON1(ILOC).NE.IB) GOTO 419
  202.  413        CONTINUE
  203. c           ici, tous les noeuds de MELEME appartiennent a la zone IB
  204.           ENDIF            
  205.  411    CONTINUE
  206.  410  CONTINUE
  207.  
  208.  
  209. C----------------------------------------------------------------------
  210. c     methode RAPIDE (evitant de partitionner la geometrie)
  211. C----------------------------------------------------------------------
  212. c       write(*,*) 'combil: methode rapide',NLOC,NCOM
  213.       NZON1=NLOC
  214.       SEGINI,IELEM,MICOM
  215.  
  216. c     Creation du chpoint de sortie : MCHPO1
  217.       NSOUPO=IBMAX
  218.       SEGINI,MCHPO1
  219. c       MCHPOI=ITACH(1)
  220. c       MCHPO1.MTYPOI=MTYPOI
  221. c       MCHPO1.MOCHDE='COMBINAISON LINEAIRE'
  222. c       MCHPO1.JATTRI(1)=JATTRI(1)
  223. c       MCHPO1.IFOPOI=IFOPOI
  224.  
  225. c     boucle sur les chpoints en entree
  226.       DO 700 III = 1,NCH
  227.         MCHPOI = ITACH(III)
  228.         VAL    = TAFL(III)
  229.         NSOUPO = MCHPOI.IPCHP(/1)
  230.  
  231.         DO 701 JJJ = 1,NSOUPO
  232. c         ajout de la contribution de la JJ eme zone du III eme chpoint
  233.           MSOUPO = IPCHP(JJJ)
  234.           NC0    = NOCOMP(/2)
  235.           MELEME = IGEOC
  236.           MPOVAL = IPOVAL
  237.           SEGACT,MPOVAL
  238.           N0     = VPOCHA(/1)
  239.           INUM11 = NUM(1,1)
  240.           ILOC11 = ICPR(INUM11)
  241. c         ... a la zone IB du chpoint de sortie
  242.           IB     = IZON1(ILOC11)
  243.           MSOUP1 = MCHPO1.IPCHP(IB)
  244.           IPT1   = IIPT1(IB)
  245.  
  246. c        +si MSOUP1 n'existe pas il faut creer MSOUP1 et MPOVA1
  247.           IF(MSOUP1.LE.0) THEN
  248.             NC=NC0
  249.             N=N0
  250.             SEGINI,MSOUP1=MSOUPO
  251.             MCHPO1.IPCHP(IB)=MSOUP1
  252.             MSOUP1.IGEOC=IPT1
  253. c           pas de pb de composante car on a duplique
  254.             SEGINI,MPOVA1
  255.             MSOUP1.IPOVAL=MPOVA1
  256. c          -cas maillage identique : pas de pb
  257.             IF(MELEME.EQ.IPT1) THEN
  258.               DO 710 K1=1,N0
  259.               DO 710 K2=1,NC0
  260.                 MPOVA1.VPOCHA(K1,K2)=VAL*VPOCHA(K1,K2)
  261.  710          CONTINUE
  262. c          -cas maillages differents : 
  263. c           on remplit IELEM(#local)=#element de IPT1
  264.             ELSE
  265. c             rem : on ne remet pas a 0 IELEM car on va parcourir 
  266. c                   exactement les noeuds remplis
  267.               DO IEL=1,IPT1.NUM(/2)
  268.                 ILOC=ICPR(IPT1.NUM(1,IEL))
  269.                 IELEM(ILOC)=IEL
  270.               ENDDO
  271.               DO 712 K1=1,N0
  272.                 ILOC=ICPR(NUM(1,K1))
  273.                 IEL=IELEM(ILOC)
  274.                 DO 713 K2=1,NC0
  275.                   MPOVA1.VPOCHA(K1,K2)=VAL*VPOCHA(IEL,K2)
  276.  713            CONTINUE
  277.  712          CONTINUE
  278.             ENDIF
  279.  
  280. c        +MSOUP1 deja existant
  281.           ELSE
  282. c          -recensement des composantes
  283.             NC1=MSOUP1.NOCOMP(/2)
  284.             NC=NC1
  285.             MPOVA1=MSOUP1.IPOVAL
  286.             N1=MPOVA1.VPOCHA(/1)
  287.             N=N1
  288.             DO 730 IC=1,NC0
  289.               DO 731 IC1=1,NC1
  290.                 IF(NOCOMP(IC).NE.MSOUP1.NOCOMP(IC1)) GOTO 731
  291.                 IF(NOHARM(IC).EQ.MSOUP1.NOHARM(IC1)) GOTO 732            
  292.  731          CONTINUE  
  293. c             on n'a pas trouve la composante IC : on agrandit
  294.               NC=NC+1
  295.               SEGADJ,MSOUP1
  296.               IC1=NC
  297.               MSOUP1.NOCOMP(IC1)=NOCOMP(IC)
  298.               MSOUP1.NOHARM(IC1)=NOHARM(IC)
  299.  732          CONTINUE
  300. c             on a trouve la composante IC en IC1
  301.               MICOM(IC)=IC1              
  302.  730        CONTINUE
  303.             IF(NC.GT.NC1) SEGADJ,MPOVA1
  304. c          -cas maillage identique : pas de pb
  305.             IF(MELEME.EQ.IPT1) THEN
  306.               DO 750 K1=1,N0
  307.               DO 751 K2=1,NC0
  308.                 IC1=MICOM(K2)
  309.                 MPOVA1.VPOCHA(K1,IC1)=(VAL*VPOCHA(K1,K2))
  310.      &         +MPOVA1.VPOCHA(K1,IC1)
  311.  751          CONTINUE
  312.  750          CONTINUE
  313. c          -cas maillages differents : 
  314. c           on remplit IELEM(#local)=#element de IPT1
  315.             ELSE
  316.               DO IEL=1,IPT1.NUM(/2)
  317.                 ILOC=ICPR(IPT1.NUM(1,IEL))
  318.                 IELEM(ILOC)=IEL
  319.               ENDDO
  320.               DO 752 K1=1,N0
  321.                 ILOC=ICPR(NUM(1,K1))
  322.                 IEL=IELEM(ILOC)
  323.                 DO 753 K2=1,NC0
  324.                   IC1=MICOM(K2)
  325.                   MPOVA1.VPOCHA(K1,IC1)=(VAL*VPOCHA(IEL,K2))
  326.      &           +MPOVA1.VPOCHA(K1,IC1)
  327.   753          CONTINUE
  328.  752          CONTINUE
  329.             ENDIF
  330.  
  331.           ENDIF
  332.  
  333.  701    CONTINUE
  334.  
  335.  700  CONTINUE
  336.  
  337. c     Desactivation/suppression
  338.       SEGSUP,ICPR,IZON1,IIPT1,IELEM
  339.       IRETT=MCHPO1
  340.       GOTO 900
  341.  
  342.  
  343.  
  344.  419  CONTINUE
  345.       SEGSUP,IZON1
  346. C----------------------------------------------------------------------
  347. c     methode GENERALE (pas d'hypothese sur les supports)
  348. C----------------------------------------------------------------------
  349. c       write(*,*) 'combil: methode generale'
  350.  
  351. C---- DECOMPTE ET STOCKAGE DES COMPOSANTES DIFFERENTES ----
  352.       SEGINI,ITRAV,ICPR 
  353.       DO 420 III = 1,NCH
  354.         MCHPOI = ITACH(III)
  355.         DO 430 JJJ = 1,MCHPOI.IPCHP(/1)
  356.           MSOUPO = MCHPOI.IPCHP(JJJ)
  357.           DO 431 KKK = 1,MSOUPO.NOHARM(/1)
  358.             DO 432 LLL = 1,NNIN
  359.               IF(MSOUPO.NOCOMP(KKK) .NE. ITRAV.INC (LLL)) GOTO 432
  360.               IF(MSOUPO.NOHARM(KKK) .EQ. ITRAV.IHAR(LLL)) GOTO 431
  361.  432        CONTINUE
  362. c           nouveau ddl : on l'ajoute a la liste ITRAV
  363.             NNIN = NNIN + 1
  364.             ITRAV.INC (NNIN)=MSOUPO.NOCOMP(KKK)
  365.             ITRAV.IHAR(NNIN)=MSOUPO.NOHARM(KKK)
  366.  431      CONTINUE 
  367.           IPT1  =MSOUPO.IGEOC
  368.           MPOVAL=MSOUPO.IPOVAL
  369. c           SEGACT,IPT1,MPOVAL
  370.           SEGACT,MPOVAL
  371.           DO 433 MMM=1,IPT1.NUM(/2)
  372.             INOEUD=IPT1.NUM(1,MMM)
  373. c           nouveau noeud : on l'ajoute a la liste ICPR
  374.             IF(ICPR(INOEUD) .EQ. 0) THEN
  375.               NNNOE = NNNOE + 1
  376.               ICPR(INOEUD)= NNNOE
  377.             ENDIF
  378.  433      CONTINUE
  379.  430    CONTINUE
  380.  420  CONTINUE
  381.  
  382. C---- CREATION DE MTRAV ET REMPLISSAGE ----
  383.       SEGINI,MTRAV 
  384.       DO 450 III = 1,NCH
  385.         MCHPOI = ITACH(III)
  386.         VAL    = TAFL(III)
  387.         DO 460 JJJ = 1,MCHPOI.IPCHP(/1)
  388.           MSOUPO=MCHPOI.IPCHP(JJJ)
  389.           IPT1  =MSOUPO.IGEOC
  390.           MPOVAL=MSOUPO.IPOVAL 
  391. C         Recherche de la composante correspondante
  392.           DO 461 KKK=1,MSOUPO.NOCOMP(/2)
  393.             DO 462 LLL=1,NNIN
  394.               IF(MSOUPO.NOCOMP(KKK) .NE. ITRAV.INC (LLL)) GOTO 462
  395.               IF(MSOUPO.NOHARM(KKK) .EQ. ITRAV.IHAR(LLL)) GOTO 463
  396.  462        CONTINUE
  397.             CALL ERREUR(5)
  398.  463        CONTINUE 
  399. C             on procede a la combinaison lineaire des valeurs 
  400. c             en 1 pt d'une meme composante
  401.               DO 465 MMM=1,IPT1.NUM(/2)
  402.                 INOEUD      =ICPR(IPT1.NUM(1,MMM))
  403.                 IGEO(INOEUD)= IPT1.NUM(1,MMM)
  404.                 IBIN(LLL,INOEUD)= 1
  405.                 BB  (LLL,INOEUD)= BB(LLL,INOEUD)
  406.      &          +(VAL*MPOVAL.VPOCHA(MMM,KKK))
  407.  465          CONTINUE 
  408.  461      CONTINUE 
  409. c           SEGDES,IPT1,MPOVAL,MSOUPO
  410.           SEGDES,MPOVAL
  411.  460    CONTINUE       
  412. c         SEGDES,MCHPOI 
  413. C       Remplissage des NOMS de composante et NUMEROS d'harmoniques
  414.         DO 451 JJJ = 1,NNIN
  415.           INCO(JJJ)=ITRAV.INC (JJJ)
  416.           NHAR(JJJ)=ITRAV.IHAR(JJJ)
  417.  451    CONTINUE
  418.  450  CONTINUE
  419.       SEGSUP,ITRAV,ICPR
  420.  
  421. C---- FERMETURE DE TOUS LES MCHPOI ----
  422.       DO 500 III = 1,NCH
  423.         MCHPOI = ITACH(III)
  424.         DO 510 JJJ = 1,MCHPOI.IPCHP(/1)
  425.           MSOUPO=MCHPOI.IPCHP(JJJ)
  426.           IPT1  =MSOUPO.IGEOC
  427.           SEGDES,IPT1,MSOUPO        
  428.  510    CONTINUE
  429.         SEGDES,MCHPOI
  430.  500  CONTINUE
  431.  
  432.  
  433. C---- CREATION DU CHPOINT FINAL A PARTIR DU MTRAV ----
  434.       CALL CRECHP (MTRAV,ID1)
  435.       SEGSUP,MTRAV
  436.       IRETT=ID1
  437.  
  438.  
  439.  900  CONTINUE
  440. C---- DERNIERS AJUSTEMENTS DU CHPOINT FINAL ----
  441.       MCHPOI=IRETT
  442. C     Dans crechp "NAT" vaut 1, on AJUSTE le SEGMENT si besoin
  443.       SEGACT,MCHPOI*MOD
  444.       IF (NAT .GT. MCHPOI.JATTRI(/1))SEGADJ,MCHPOI
  445. C     Le chapeau du CHPOINT est complete d'apres le premier de la liste
  446.       MCHPO4 = ITACH(1)
  447.       SEGACT,MCHPO4
  448.       MCHPOI.MTYPOI=CHA8b
  449.       MCHPOI.MOCHDE='COMBINAISON LINEAIRE'
  450.       DO IATT=1,NAT
  451.         MCHPOI.JATTRI(IATT)=NATf
  452.       ENDDO 
  453.       MCHPOI.IFOPOI=MCHPO4.IFOPOI
  454.       SEGDES,MCHPOI,MCHPO4
  455.  
  456.       RETURN      
  457.  
  458.       END
  459.  
  460.  
  461.  
  462.  
  463.  
  464.  
  465.  
  466.  

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