Télécharger la plaquette Cast3M


fr en

Télécharger adchpo.eso

Retour à la liste

Numérotation des lignes : 

adchpo

  1. C ADCHPO    SOURCE    GOUNAND   25/05/05    21:15:01     12259          
  2.       SUBROUTINE ADCHPO(IPO1,IPO2,IRET,XCO1,XCO2)
  3. C=======================================================================
  4. C
  5. C     COMBINAISON LINEAIRE DE 2 CHPS PAR POINTS
  6. C-----------------------------------------------------------------------
  7. C     ON VEUT FAIRE FLO1*CHP1 + FLO2*CHP2
  8. C-----------------------------------------------------------------------
  9. C  ENTREE
  10. C     IPO1=POINTEUR SUR LE 1 CHAMP PAR POINT
  11. C     IPO2=POINTEUR SUR LE 2 CHAMP PAR POINT
  12. C     XCO1 ET XCO2 COEFFICIENTS APPLIQUES SUR LES CHAMPS
  13. C  SORTIE
  14. C     IRET= POINTEUR SUR LE CHAMP SOMME
  15. C         = 0   SI SOMME IMPOSSIBLE
  16. C
  17. C              MESSAGE D ERREUR DECLENCHE SI IRET=0
  18. C
  19. C     CODE EBERSOLT JUILLET 84  MODIF HAMY NOVEMBRE 84
  20. C
  21. C     POUR L INSTANT ON AUTORISE L ADDITION DE CHPOINTS DE SOUS
  22. C     TYPE DIFFERENTS ( STOCKES DANS MTYPOI )
  23. C
  24. C     CETTE ROUTINE FAIT APPEL A LA ROUTINE CRECHP
  25. C
  26. C=======================================================================
  27.       IMPLICIT INTEGER(I-N)
  28.       IMPLICIT REAL*8(A-H,O-Z)
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32.  
  33. -INC SMCHPOI
  34. -INC SMELEME
  35. -INC SMCOORD
  36. -INC TMTRAV
  37.       SEGMENT/MTRA/(NOPOIN(nbpts))
  38.       SEGMENT MTR1
  39.         CHARACTER*(LOCOMP) IPCOM(0)
  40.       ENDSEGMENT
  41.       SEGMENT/MTR2/(IICOM(0))
  42.       SEGMENT/MTR3/(INDEX(max(nsoup1,nsoup2)))
  43.       SEGMENT/MTR4/(IPHAR(0))
  44.       SEGMENT/MTR5/(IPOS1(NSOUP1),IPOS2(NSOUP2),
  45.      >     IZON(nbpts))
  46.       segment mtr6
  47.       character*(LOCOMP) mpcom(ncmax)
  48.       integer     micom(ncmax),nicom(ncmax)
  49.       integer     mphar(ncmax)
  50.       endsegment
  51.  
  52.       character*(LOCOMP)MOCOMP
  53. C
  54. C-----------------------------------------------------------------------
  55. C               --- DESCRIPTION DES SEGMENTS DE TRAVAIL ---
  56. C * MTRAV : - BB(I,J) EST LA VALEUR DE LA IEME INCONNUE DE CHAMP POUR
  57. C          LE JIEME NOEUD DU TABLEAU IGEO .
  58. C           - INCO(NNIN) CONTIENT LE NOM DES NNIN INCONNUES DIFFERENTES
  59. C           - IBIN(I,J)=1 OU 0 INDIQUE QUE LA IEME INCONNUE DU CHAMP
  60. C          EXISTE POUR LE JIEME NOEUD DU TABLEAU IGEO .
  61. C           - IGEO(I) EST LE NUMERO A METTRE DANS UN OBJET MELEME POUR
  62. C          REFERENCER LE IEME NOEUD .
  63. C
  64. C * MTRA  : - NOPOIN(I) ADRESSE DE COLONNE DANS BB ET IBIN DES VALEURS
  65. C          CORRESPONDANT AU NOEUD I .
  66. C
  67. C * MTR1  : - IPCOM LISTE DES NOMS DES INCONNUES PERMET DE CREER INCO .
  68. C
  69. C * MTR2  : - IICOM ADRESSE DANS IPCOM DES INCONNUES CORRESPONDANT AU
  70. C          2IEME CH POINT .
  71. C
  72. C * MTR3  : - INDEX TABLEAU DE CORRESPONDANCE ENTRE LES SUPPORTS GEOME-
  73. C          TRIQUES DU 1ER CHPOINT ET DU 2IEME CHPOINT .
  74. C-----------------------------------------------------------------------
  75.       DIMENSION IPO(2)
  76.       CHARACTER*8 MOT
  77. C
  78.       IF(IPO1.NE.IPO2) GOTO 60
  79. C
  80. C-----------------------------------------------------------------------
  81. C *** CAS OU LES 2 POINTEURS IPO1 ET IPO2 SONT EGAUX
  82. C-----------------------------------------------------------------------
  83. C
  84.       XX = XCO1 + XCO2
  85. C
  86.       if (ierr.ne.0) return
  87. C
  88.       MCHPO1=IPO1
  89.       SEGACT MCHPO1
  90.       NSOUPO=MCHPO1.IPCHP(/1)
  91.       NAT=MCHPO1.JATTRI(/1)
  92.       SEGINI MCHPOI
  93.       DO 10 I=1,NAT
  94.         JATTRI(I)=MCHPO1.JATTRI(I)
  95.  10   CONTINUE
  96.       IRET=MCHPOI
  97.       MOCHDE='CHPOINT cree par ADCHPO'
  98.       MTYPOI=MCHPO1.MTYPOI
  99.       IFOPOI=MCHPO1.IFOPOI
  100.       DO 50 IA=1,NSOUPO
  101.          MSOUP1=MCHPO1.IPCHP(IA)
  102.          SEGACT MSOUP1
  103.          NC=MSOUP1.NOCOMP(/2)
  104.          SEGINI MSOUPO
  105.          IPCHP(IA)=MSOUPO
  106.          DO 20 IB=1,NC
  107.             NOCOMP(IB)=MSOUP1.NOCOMP(IB)
  108.             NOHARM(IB)=MSOUP1.NOHARM(IB)
  109.  20      CONTINUE
  110.          IGEOC=MSOUP1.IGEOC
  111.          MPOVA1=MSOUP1.IPOVAL
  112.          SEGACT MPOVA1
  113.          N  =MPOVA1.VPOCHA(/1)
  114.          NC1=MPOVA1.VPOCHA(/2)
  115.          IF(NC1.EQ.NC)  GOTO 30
  116. C
  117. C     ERREUR PB DIMENSION TABLEAU VOIR ROUTINE ADCHPO
  118. C
  119.          IRET=0
  120.          SEGSUP MSOUPO,MCHPOI
  121.          CALL ERREUR(114)
  122.          RETURN
  123.  30      CONTINUE
  124.          SEGINI MPOVAL
  125.          IPOVAL=MPOVAL
  126.          DO 40 IC=1,NC
  127.             DO 41 IB=1,N
  128.                VPOCHA(IB,IC)=XX*MPOVA1.VPOCHA(IB,IC)
  129.  41         CONTINUE
  130.  40      CONTINUE
  131.  50   CONTINUE
  132.       RETURN
  133. C
  134. C-----------------------------------------------------------------------
  135. C *** CAS  OU LES POINTEURS IPO1 ET IPO2 SONT DIFFERENTS
  136. C-----------------------------------------------------------------------
  137. C
  138.  60   CONTINUE
  139.       IPO(1)=IPO1
  140.       IPO(2)=IPO2
  141.       XXT1 = XCO1
  142.       XXT2 = XCO2
  143.  
  144.       MCHPO1=IPO1
  145.       MCHPO2=IPO2
  146.       if (ierr.ne.0) return
  147.       SEGACT MCHPO1,MCHPO2
  148.       NSOUP1=MCHPO1.IPCHP(/1)
  149.       NSOUP2=MCHPO2.IPCHP(/1)
  150.       NAT1 = MCHPO1.JATTRI(/1)
  151.       NAT2 = MCHPO2.JATTRI(/1)
  152.       MOT = MCHPO1.MTYPOI
  153.       IF(MOT.NE.MCHPO2.MTYPOI) THEN
  154.          MOT='adchpo'
  155.       ENDIF
  156. C
  157. C     ON REGARDE SI UN CHAMP EST INCLUS DANS L'AUTRE
  158. C
  159. C     Cas de l'un ou l'autre des CHPOINT 'VIDE'
  160.       IF    (NSOUP1.EQ.0 .AND. NSOUP2.EQ.0)THEN
  161. C       Cela revient a faire un 'CHPOINT' 'VIDE' en recopiant les attributs
  162.         NSOUPO=0
  163.         NAT   =MAX(NAT1,NAT2,1)
  164.         SEGINI,MCHPOI
  165.         IRET=MCHPOI
  166.         IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  167.            IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  168.               JATTRI(1)= MCHPO1.JATTRI(1)
  169.            ELSE
  170.               JATTRI(1)=0
  171.            ENDIF
  172.         ELSE
  173.            JATTRI(1)=0
  174.         ENDIF
  175.         MTYPOI=MOT
  176.         MOCHDE='CHPOINT cree par ADCHPO'
  177.         IFOPOI=IFOUR
  178.         RETURN
  179.  
  180.       ELSEIF(NSOUP1.EQ.0 .AND. NSOUP2.NE.0)THEN
  181. C       Cela revient a une multiplication de MCHPO2 par XCO2
  182.         IOPERA=2
  183.         IARGU =2
  184.         I1    =0
  185.         CALL OPCHP1(MCHPO2,IOPERA,IARGU,I1,XCO2,IRET,IOK)
  186.         RETURN
  187.  
  188.       ELSEIF(NSOUP1.NE.0 .AND. NSOUP2.EQ.0)THEN
  189. C       Cela revient a une multiplication de MCHPO1 par XCO1
  190.         IOPERA=2
  191.         IARGU =2
  192.         I1    =0
  193.         CALL OPCHP1(MCHPO1,IOPERA,IARGU,I1,XCO1,IRET,IOK)
  194.         RETURN
  195.       ENDIF
  196. C
  197. C Cas general : les 2 champs ne sont pas vides
  198. C
  199.       ifo1 = MCHPO1.IFOPOI
  200.       ifo2 = MCHPO2.IFOPOI
  201.       ifos = ifo1
  202.       IF (ifo1 .NE. ifo2) THEN
  203.         moterr(1:8)='CHPOINT'
  204.         interr(1)=ifo1
  205.         interr(2)=ifo2
  206.         interr(3)=IFOUR
  207. c-dbg      write(ioimp,*) '1132 ADCHPO',ipo1,ipo2
  208.         call erreur(1132)
  209.         ifos = IFOUR
  210.       END IF
  211. C
  212. C     ON REGARDE SI on peut se passer de repartionner la geometrie
  213. C
  214.       SEGINI MTR5
  215.       SEGINI MTR3
  216.       ncmax2=0
  217.       nposr=0
  218.       DO 100 IB=1,NSOUP2
  219.          MSOUP2=MCHPO2.IPCHP(IB)
  220.          SEGACT MSOUP2
  221.          ncmax2=max(ncmax2,msoup2.nocomp(/2))
  222.          ipt2=MSOUP2.IGEOC
  223.          segact ipt2
  224.          do 101 iel=1,ipt2.num(/2)
  225.             izon(ipt2.num(1,iel))=ib
  226.  101     continue
  227.  100  continue
  228.       ncmax1=0
  229.       do 105 ia=1,nsoup1
  230.          msoup1=mchpo1.ipchp(ia)
  231.          segact msoup1
  232.          ncmax1=max(ncmax1,msoup1.nocomp(/2))
  233.          ipt1=msoup1.igeoc
  234.          segact ipt1
  235.          ib=0
  236.          if (ipt1.num(/2).gt.0) ib=izon(ipt1.num(1,1))
  237.          if (ib.eq.0) then
  238.             do 106 iel=1,ipt1.num(/2)
  239.                if (izon(ipt1.num(1,iel)).ne.0) then
  240.                   if (iimpi.eq.1954)
  241.      >                 write (ioimp,*)
  242.      $                 ' adchpo zone 1ch coupe zone 2ch ',ia
  243.      $                 ,izon(ipt1.num(1,iel))
  244.                   goto 109
  245.                endif
  246.  106        continue
  247.             goto 105
  248.          endif
  249.          MSOUP2=MCHPO2.IPCHP(IB)
  250. *  si meme nombre d'elements on compare les meleme
  251.          ipt2=msoup2.igeoc
  252.          IF(ipt1.eq.ipt2) GO TO 90
  253.          if (ipt1.num(/2).ne.ipt2.num(/2))then
  254.             if (iimpi.eq.1954)
  255.      >           write (ioimp,*) ' adchpo nbel diff ',ipt1.num(/2)
  256.      $           ,ipt2.num(/2)
  257.             goto 109
  258.          endif
  259.          do 84 iel=1,ipt1.num(/2)
  260.             if (izon(ipt1.num(1,iel)).ne.ib) then
  261.                if (iimpi.eq.1954)
  262.      >              write (ioimp,*) ' adchpo zone mismatch '
  263.                goto 109
  264.             endif
  265.  84      continue
  266.  90      CONTINUE
  267.          nposr=nposr+1
  268.          ipos1(ia)=1
  269.          ipos2(ib)=1
  270.          INDEX(ia)=IB
  271.  105  CONTINUE
  272.       npaq1=0
  273.       do 82 ipaq=1,nsoup1
  274.          npaq1=npaq1+ipos1(ipaq)
  275.  82   continue
  276.       npaq2=0
  277.       do 83 ipaq=1,nsoup2
  278.          npaq2=npaq2+ipos2(ipaq)
  279.  83   continue
  280.       if (iimpi.eq.1954) write (ioimp,*) ' adchpo rapide '
  281.       goto 108
  282.  109  continue
  283. C
  284. C     tous les meleme de l'un ne sont pas inclus dans l'autre
  285. C
  286.       SEGSUP MTR3,MTR5
  287.       GO TO 300
  288.  108  continue
  289. C
  290. C *** CAS OU LES SUPPORTS GEOMETRIQUES DE L'UN SONT INCLUS DANS L'AUTRE
  291. C
  292.       NSOUPO=NSOUP1+NSOUP2-nposr
  293.       NAT=MAX(NAT1,NAT2,1)
  294.       SEGINI MCHPOI
  295.       IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  296.          IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  297.             JATTRI(1)= MCHPO1.JATTRI(1)
  298.          ELSE
  299.             JATTRI(1)=0
  300.          ENDIF
  301.       ELSE
  302.          JATTRI(1)=0
  303.       ENDIF
  304.       IRET=MCHPOI
  305.       MTYPOI=MOT
  306.       MOCHDE='CHPOINT cree par ADCHPO'
  307.       IFOPOI=ifos
  308.       ncmax=ncmax1+ncmax2
  309. *goo      SEGINI mtr6
  310.       nposr=0
  311.       DO 250 IA=1,NSOUP1
  312.          SEGINI mtr6
  313.          if (ipos1(ia).eq.0) goto 250
  314.          MSOUP1=MCHPO1.IPCHP(IA)
  315.          MSOUP2=MCHPO2.IPCHP(INDEX(IA))
  316.          SEGACT MSOUP1,MSOUP2
  317. C
  318. C     COMPARAISON DES NOMS DES COMPOSANTES
  319. C
  320.          NC1=MSOUP1.NOCOMP(/2)
  321.          NC2=MSOUP2.NOCOMP(/2)
  322.          DO 130 IB=1,NC1
  323.             mpcom(ib)=MSOUP1.NOCOMP(IB)
  324.             mphar(ib)=MSOUP1.NOHARM(IB)
  325.  130     CONTINUE
  326.          mc=nc1
  327.          DO 160 IB=1,NC2
  328.             DO 140 IC=1,NC1
  329.                IF(MSOUP2.NOCOMP(IB).NE.MSOUP1.NOCOMP(IC)) GOTO 140
  330.                IF(MSOUP2.NOHARM(IB).EQ.MSOUP1.NOHARM(IC)) GOTO 150
  331.  140        CONTINUE
  332.             mc=mc+1
  333.             mpcom(mc)=MSOUP2.NOCOMP(IB)
  334.             mphar(mc)=MSOUP2.NOHARM(IB)
  335.             micom(ib)=mc
  336.             GO TO 160
  337.  150        CONTINUE
  338.             micom(ib)=ic
  339.             nicom(ic)=1
  340.  160     CONTINUE
  341. C
  342.          MPOVA1=MSOUP1.IPOVAL
  343.          MPOVA2=MSOUP2.IPOVAL
  344.          SEGACT MPOVA1,MPOVA2
  345.          N1=MPOVA1.VPOCHA(/1)
  346.          N2=MPOVA2.VPOCHA(/1)
  347.          NCX1=MPOVA1.VPOCHA(/2)
  348.          NCX2=MPOVA2.VPOCHA(/2)
  349.          IF(NCX1.NE.NC1) GOTO 170
  350.          IF(NCX2.NE.NC2) GOTO 170
  351.          IF(N1.NE.N2)    GOTO 170
  352.          GOTO 180
  353.  170     CONTINUE
  354.          SEGSUP MTR6,MCHPOI,MTR3,MTR5
  355. C
  356. C     PB AVEC LES DIMENSIONS DES CHPOINTS
  357. C
  358.          CALL ERREUR(114)
  359.          IRET=0
  360.          RETURN
  361. *
  362.  180     CONTINUE
  363. *
  364.          N=N1
  365.          NC=mc
  366.          SEGINI MPOVAL
  367. C
  368. C     recopier le premier chpo
  369. C
  370.          DO 210 IC=1,NC1
  371.             if (nicom(ic).eq.0) then
  372.                DO 200 IB=1,N
  373.                   VPOCHA(IB,IC)=XXT1*MPOVA1.VPOCHA(IB,IC)
  374.  200           CONTINUE
  375.             endif
  376.  210     CONTINUE
  377. C
  378. C     rajouter le second
  379. C
  380.          ipt1=msoup1.igeoc
  381.          ipt2=msoup2.igeoc
  382. *  si les numerotations sont differentes il faut reordonner
  383.          if (ipt1.ne.ipt2) then
  384.             do 229 iel=1,ipt2.num(/2)
  385.                izon(ipt2.num(1,iel))=iel
  386.  229        continue
  387.             DO 230 IC=1,NC2
  388.                IIC=micom(ic)
  389.                if (iic.gt.nc1) then
  390.                   DO 221 IB=1,N
  391.                      VPOCHA(IB,IIC)=XXT2*
  392.      $                    MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC)
  393.  221              CONTINUE
  394.                else
  395.                   DO 220 IB=1,N
  396.                      VPOCHA(IB,IIC)=XXT1*mpova1.VPOCHA(IB,IIC)
  397.      $                    +XXT2*MPOVA2.VPOCHA(izon(ipt1.num(1,ib))
  398.      $                    ,IC)
  399.  220              CONTINUE
  400.                endif
  401.  230        CONTINUE
  402.          else
  403. *  meme pointeur geometrique on se passe de izon
  404.             DO 235 IC=1,NC2
  405.                IIC=micom(ic)
  406.                if (iic.gt.nc1) then
  407.                   DO 236 IB=1,N
  408.                      VPOCHA(IB,IIC)=XXT2*MPOVA2.VPOCHA(IB,IC)
  409.  236              CONTINUE
  410.                else
  411.                   DO 237 IB=1,N
  412.                      VPOCHA(IB,IIC)=XXT1*mpova1.VPOCHA(IB,IIC)+
  413.      >                    XXT2*MPOVA2.VPOCHA(IB,IC)
  414.  237              CONTINUE
  415.                endif
  416.  235        CONTINUE
  417.          endif
  418. C
  419.          SEGINI MSOUPO
  420.          DO 240 IB=1,NC
  421.             NOCOMP(IB)=mpcom(ib)
  422.             NOHARM(IB)=mphar(ib)
  423.  240     CONTINUE
  424.          IPOVAL=MPOVAL
  425.          IPT3=IPT1
  426.          IGEOC=IPT3
  427.          nposr=nposr+1
  428.          IPCHP(nposr)=MSOUPO
  429.          SEGSUP MTR6
  430.  250  CONTINUE
  431. *goo      SEGSUP MTR6
  432. *  il faut maintenant adjoindre les paquets de 1 pas dans 2 ou inversement
  433.       DO 251 IA=1,NSOUP1
  434.          if (ipos1(ia).ne.0) goto 251
  435.          nposr=nposr+1
  436.          msoupo=mchpo1.ipchp(ia)
  437.          segini,msoup1=msoupo
  438.          ipchp(nposr)=msoup1
  439.          mpoval=msoup1.ipoval
  440.          segact mpoval
  441.          n=vpocha(/1)
  442.          nc=vpocha(/2)
  443.          segini,mpova1
  444.          do 254 jb=1,nc
  445.             do 2541 ja=1,n
  446.                mpova1.vpocha(ja,jb)=xxt1*vpocha(ja,jb)
  447.  2541       continue
  448.  254     continue
  449.          msoup1.ipoval=mpova1
  450.  251  continue
  451.       DO 252 IB=1,NSOUP2
  452.          if (ipos2(ib).ne.0) goto 252
  453.          nposr=nposr+1
  454.          msoupo=mchpo2.ipchp(ib)
  455.          segini,msoup1=msoupo
  456.          ipchp(nposr)=msoup1
  457.          mpoval=msoup1.ipoval
  458.          segact mpoval
  459.          n=vpocha(/1)
  460.          nc=vpocha(/2)
  461.          segini,mpova1
  462.          do 253 jb=1,nc
  463.             do 2531 ja=1,n
  464.                mpova1.vpocha(ja,jb)=xxt2*vpocha(ja,jb)
  465.  2531       continue
  466.  253     continue
  467.          msoup1.ipoval=mpova1
  468.  252  continue
  469. *  verification que les composantes sont bien differentes entre paquets
  470.       do 255 isoupo=1,ipchp(/1)
  471.          msoup1=ipchp(isoupo)
  472.          SEGACT MSOUP1
  473.          nc1=msoup1.nocomp(/2)
  474.          do 256 jsoupo=isoupo+1,ipchp(/1)
  475.             msoup2=ipchp(jsoupo)
  476.             SEGACT MSOUP2
  477.             nc2=msoup2.nocomp(/2)
  478.             if (nc1.ne.nc2) goto 256
  479.             do 257 ic1=1,nc1
  480.                do 258 ic2=1,nc2
  481.                   if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2))
  482.      $                 goto 258
  483.                   if (msoup1.nocomp(ic1).eq.msoup2.nocomp(ic2))
  484.      $                 goto 257
  485.  258           continue
  486.                goto 256
  487.  257        continue
  488. *  pas de chance composantes en double
  489.             if (iimpi.eq.1954) write (ioimp,*)
  490.      $           ' pacquets en double => lent '
  491.             segsup mtr3,mtr5
  492.             goto 300
  493.  256     continue
  494.  255  continue
  495.       SEGSUP MTR3,MTR5
  496.  
  497.       RETURN
  498. C
  499. C *** CAS OU LES SUPPORTS GEOMETRIQUES NE SONT PAS IDENTIQUES
  500. C *** A UNE PERMUTATION PRES
  501. C
  502.  300  CONTINUE
  503. C
  504.       SEGINI MTRA,MTR1,MTR4
  505. C
  506.       MCHPOI=IPO1
  507.       SEGACT MCHPOI
  508.       MSOUPO=IPCHP(1)
  509.       SEGACT MSOUPO
  510.       IPCOM(**)=NOCOMP(1)
  511.       IPHAR(**)=NOHARM(1)
  512.       NC=1
  513.       IK=0
  514. C
  515. C     CREATION DE NOPOIN ET DE IPCOM
  516. C
  517.       DO 360 ICH=1,2
  518.          MCHPOI=IPO(ICH)
  519.          SEGACT MCHPOI
  520.          NSOUPO=IPCHP(/1)
  521. C
  522. C     BOUCLE SUR LES SOUS REFERENCES D 1 CHPOINT
  523. C
  524.          DO 350 IA=1,NSOUPO
  525.             MSOUPO=IPCHP(IA)
  526.             SEGACT MSOUPO
  527.             MELEME=IGEOC
  528.             SEGACT MELEME
  529.             NBNN  =NUM(/1)
  530.             NBELEM=NUM(/2)
  531. C     IF(NBNN.NE.1) GOTO 777
  532.             DO 310 IB=1,NBELEM
  533.                K=NUM(1,IB)
  534.                IF(NOPOIN(K).NE.0) GO TO 310
  535.                IK=IK+1
  536.                NOPOIN(K)=IK
  537.  310        CONTINUE
  538.             NCBBB=NOCOMP(/2)
  539.             DO 330 IB=1,NCBBB
  540.                NC=IPCOM(/2)
  541.                DO 320 IC=1,NC
  542.                   IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320
  543.                   IF(IPHAR(IC).EQ.NOHARM(IB))  GO TO 330
  544.  320           CONTINUE
  545.                IPCOM(**)=NOCOMP(IB)
  546.                IPHAR(**)=NOHARM(IB)
  547.                NC=NC+1
  548.  330        CONTINUE
  549.  350     CONTINUE
  550.  360  CONTINUE
  551. C
  552.       NNIN=NC
  553.       NNNOE=IK
  554.       SEGINI MTRAV
  555. C
  556. C     CREATION DE INCO
  557. C
  558.       DO 380 IA=1,NNIN
  559.          INCO(IA)=IPCOM(IA)
  560.          NHAR(IA)=IPHAR(IA)
  561.  380  CONTINUE
  562. C
  563. C     CREATION DE BB,IBIN,IGEO
  564. C
  565.       MCHPOI=IPO(1)
  566.       SEGACT MCHPOI
  567.       NSOUPO=IPCHP(/1)
  568.       DO 1430 IA=1,NSOUPO
  569.          MSOUPO=IPCHP(IA)
  570.          SEGACT MSOUPO
  571.          MELEME=IGEOC
  572.          SEGACT MELEME
  573.          MPOVAL=IPOVAL
  574.          SEGACT MPOVAL
  575.          NBELEM=NUM(/2)
  576.          if (nbelem.ne.vpocha(/1)) then
  577.           call erreur(114)
  578.           iret=0
  579.          RETURN
  580.          endif
  581.          N=VPOCHA(/1)
  582.          NC=VPOCHA(/2)
  583.          NC1=NOCOMP(/2)
  584. C
  585.          DO 1420 IB=1,NC1
  586.             DO 1390 IC=1,NNIN
  587.                IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 1390
  588.                IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 1400
  589.  1390       CONTINUE
  590.  1400       CONTINUE
  591.             DO 1410 ID=1,NBELEM
  592.                KI=NOPOIN(NUM(1,ID))
  593.                IGEO(KI)=NUM(1,ID)
  594.                IBIN(IC,KI)=1
  595.                BB(IC,KI)=XXT1*VPOCHA(ID,IB)
  596.  1410       CONTINUE
  597.  1420    CONTINUE
  598.  1430 CONTINUE
  599.  
  600.       MCHPOI=IPO(2)
  601.       SEGACT MCHPOI
  602.       NSOUPO=IPCHP(/1)
  603.       DO 430 IA=1,NSOUPO
  604.          MSOUPO=IPCHP(IA)
  605.          SEGACT MSOUPO
  606.          MELEME=IGEOC
  607.          SEGACT MELEME
  608.          MPOVAL=IPOVAL
  609.          SEGACT MPOVAL
  610.          NBELEM=NUM(/2)
  611.          N=VPOCHA(/1)
  612.          NC=VPOCHA(/2)
  613.          NC1=NOCOMP(/2)
  614. C
  615.          DO 420 IB=1,NC1
  616.             DO 390 IC=1,NNIN
  617.                IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390
  618.                IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400
  619.  390        CONTINUE
  620.  400        CONTINUE
  621.             DO 410 ID=1,NBELEM
  622.                KI=NOPOIN(NUM(1,ID))
  623.                IGEO(KI)=NUM(1,ID)
  624.                IBIN(IC,KI)=1
  625.                BB(IC,KI)=BB(IC,KI)+XXT2*VPOCHA(ID,IB)
  626.  410        CONTINUE
  627.  420     CONTINUE
  628.  430  CONTINUE
  629.       ITRAV=MTRAV
  630. C
  631. C     RECONSTUCTION DE LA PARTITION
  632. C
  633.       CALL CRECHP(ITRAV,ICHPOI)
  634. C
  635.       SEGSUP MTRAV,MTRA,MTR1,MTR4
  636.       IRET   = ICHPOI
  637.       MCHPOI = ICHPOI
  638.       MCHPO1 = IPO1
  639.       MCHPO2 = IPO2
  640.       SEGACT MCHPO1,MCHPO2
  641.       NAT1 = MCHPO1.JATTRI(/1)
  642.       NAT2 = MCHPO2.JATTRI(/1)
  643.       NAT=MAX(NAT1,NAT2,1)
  644.       NSOUPO = IPCHP(/1)
  645.       SEGADJ,MCHPOI
  646.       IRET  =MCHPOI
  647.       MTYPOI=MOT
  648.       IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  649.          IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  650.             JATTRI(1)= MCHPO1.JATTRI(1)
  651.          ELSE
  652.             JATTRI(1)=0
  653.          ENDIF
  654.       ELSE
  655.          JATTRI(1)=0
  656.       ENDIF
  657.  
  658.       END
  659.  
  660.  

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