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/11/12    21:15:02     12399          
  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.          CALL COMBNA(MCHPO1,MCHPO2,INAT,IATTR)
  164.          NAT=INAT
  165.          SEGINI,MCHPOI
  166.          IRET=MCHPOI
  167.          JATTRI(1)=IATTR
  168.          MTYPOI=MOT
  169.          MOCHDE='CHPOINT cree par ADCHPO'
  170.          IFOPOI=IFOUR
  171.          RETURN
  172.  
  173.       ELSEIF(NSOUP1.EQ.0 .AND. NSOUP2.NE.0)THEN
  174. C       Cela revient a une multiplication de MCHPO2 par XCO2
  175.         IOPERA=2
  176.         IARGU =2
  177.         I1    =0
  178.         CALL OPCHP1(MCHPO2,IOPERA,IARGU,I1,XCO2,IRET,IOK)
  179.         RETURN
  180.  
  181.       ELSEIF(NSOUP1.NE.0 .AND. NSOUP2.EQ.0)THEN
  182. C       Cela revient a une multiplication de MCHPO1 par XCO1
  183.         IOPERA=2
  184.         IARGU =2
  185.         I1    =0
  186.         CALL OPCHP1(MCHPO1,IOPERA,IARGU,I1,XCO1,IRET,IOK)
  187.         RETURN
  188.       ENDIF
  189. C
  190. C Cas general : les 2 champs ne sont pas vides
  191. C
  192.       ifo1 = MCHPO1.IFOPOI
  193.       ifo2 = MCHPO2.IFOPOI
  194.       ifos = ifo1
  195.       IF (ifo1 .NE. ifo2) THEN
  196.         moterr(1:8)='CHPOINT'
  197.         interr(1)=ifo1
  198.         interr(2)=ifo2
  199.         interr(3)=IFOUR
  200. c-dbg      write(ioimp,*) '1132 ADCHPO',ipo1,ipo2
  201.         call erreur(1132)
  202.         ifos = IFOUR
  203.       END IF
  204. C
  205. C     ON REGARDE SI on peut se passer de repartionner la geometrie
  206. C
  207.       SEGINI MTR5
  208.       SEGINI MTR3
  209.       ncmax2=0
  210.       nposr=0
  211.       DO 100 IB=1,NSOUP2
  212.          MSOUP2=MCHPO2.IPCHP(IB)
  213.          SEGACT MSOUP2
  214.          ncmax2=max(ncmax2,msoup2.nocomp(/2))
  215.          ipt2=MSOUP2.IGEOC
  216.          segact ipt2
  217.          do 101 iel=1,ipt2.num(/2)
  218.             izon(ipt2.num(1,iel))=ib
  219.  101     continue
  220.  100  continue
  221.       ncmax1=0
  222.       do 105 ia=1,nsoup1
  223.          msoup1=mchpo1.ipchp(ia)
  224.          segact msoup1
  225.          ncmax1=max(ncmax1,msoup1.nocomp(/2))
  226.          ipt1=msoup1.igeoc
  227.          segact ipt1
  228.          ib=0
  229.          if (ipt1.num(/2).gt.0) ib=izon(ipt1.num(1,1))
  230.          if (ib.eq.0) then
  231.             do 106 iel=1,ipt1.num(/2)
  232.                if (izon(ipt1.num(1,iel)).ne.0) then
  233.                   if (iimpi.eq.1954)
  234.      >                 write (ioimp,*)
  235.      $                 ' adchpo zone 1ch coupe zone 2ch ',ia
  236.      $                 ,izon(ipt1.num(1,iel))
  237.                   goto 109
  238.                endif
  239.  106        continue
  240.             goto 105
  241.          endif
  242.          MSOUP2=MCHPO2.IPCHP(IB)
  243. *  si meme nombre d'elements on compare les meleme
  244.          ipt2=msoup2.igeoc
  245.          IF(ipt1.eq.ipt2) GO TO 90
  246.          if (ipt1.num(/2).ne.ipt2.num(/2))then
  247.             if (iimpi.eq.1954)
  248.      >           write (ioimp,*) ' adchpo nbel diff ',ipt1.num(/2)
  249.      $           ,ipt2.num(/2)
  250.             goto 109
  251.          endif
  252.          do 84 iel=1,ipt1.num(/2)
  253.             if (izon(ipt1.num(1,iel)).ne.ib) then
  254.                if (iimpi.eq.1954)
  255.      >              write (ioimp,*) ' adchpo zone mismatch '
  256.                goto 109
  257.             endif
  258.  84      continue
  259.  90      CONTINUE
  260.          nposr=nposr+1
  261.          ipos1(ia)=1
  262.          ipos2(ib)=1
  263.          INDEX(ia)=IB
  264.  105  CONTINUE
  265.       npaq1=0
  266.       do 82 ipaq=1,nsoup1
  267.          npaq1=npaq1+ipos1(ipaq)
  268.  82   continue
  269.       npaq2=0
  270.       do 83 ipaq=1,nsoup2
  271.          npaq2=npaq2+ipos2(ipaq)
  272.  83   continue
  273.       if (iimpi.eq.1954) write (ioimp,*) ' adchpo rapide '
  274.       goto 108
  275.  109  continue
  276. C
  277. C     tous les meleme de l'un ne sont pas inclus dans l'autre
  278. C
  279.       SEGSUP MTR3,MTR5
  280.       GO TO 300
  281.  108  continue
  282. C
  283. C *** CAS OU LES SUPPORTS GEOMETRIQUES DE L'UN SONT INCLUS DANS L'AUTRE
  284. C
  285.       NSOUPO=NSOUP1+NSOUP2-nposr
  286.       CALL COMBNA(MCHPO1,MCHPO2,INAT,IATTR)
  287.       NAT=INAT
  288.       SEGINI MCHPOI
  289.       JATTRI(1)=IATTR
  290.       IRET=MCHPOI
  291.       MTYPOI=MOT
  292.       MOCHDE='CHPOINT cree par ADCHPO'
  293.       IFOPOI=ifos
  294.       ncmax=ncmax1+ncmax2
  295. *goo      SEGINI mtr6
  296.       nposr=0
  297.       DO 250 IA=1,NSOUP1
  298.          SEGINI mtr6
  299.          if (ipos1(ia).eq.0) goto 250
  300.          MSOUP1=MCHPO1.IPCHP(IA)
  301.          MSOUP2=MCHPO2.IPCHP(INDEX(IA))
  302.          SEGACT MSOUP1,MSOUP2
  303. C
  304. C     COMPARAISON DES NOMS DES COMPOSANTES
  305. C
  306.          NC1=MSOUP1.NOCOMP(/2)
  307.          NC2=MSOUP2.NOCOMP(/2)
  308.          DO 130 IB=1,NC1
  309.             mpcom(ib)=MSOUP1.NOCOMP(IB)
  310.             mphar(ib)=MSOUP1.NOHARM(IB)
  311.  130     CONTINUE
  312.          mc=nc1
  313.          DO 160 IB=1,NC2
  314.             DO 140 IC=1,NC1
  315.                IF(MSOUP2.NOCOMP(IB).NE.MSOUP1.NOCOMP(IC)) GOTO 140
  316.                IF(MSOUP2.NOHARM(IB).EQ.MSOUP1.NOHARM(IC)) GOTO 150
  317.  140        CONTINUE
  318.             mc=mc+1
  319.             mpcom(mc)=MSOUP2.NOCOMP(IB)
  320.             mphar(mc)=MSOUP2.NOHARM(IB)
  321.             micom(ib)=mc
  322.             GO TO 160
  323.  150        CONTINUE
  324.             micom(ib)=ic
  325.             nicom(ic)=1
  326.  160     CONTINUE
  327. C
  328.          MPOVA1=MSOUP1.IPOVAL
  329.          MPOVA2=MSOUP2.IPOVAL
  330.          SEGACT MPOVA1,MPOVA2
  331.          N1=MPOVA1.VPOCHA(/1)
  332.          N2=MPOVA2.VPOCHA(/1)
  333.          NCX1=MPOVA1.VPOCHA(/2)
  334.          NCX2=MPOVA2.VPOCHA(/2)
  335.          IF(NCX1.NE.NC1) GOTO 170
  336.          IF(NCX2.NE.NC2) GOTO 170
  337.          IF(N1.NE.N2)    GOTO 170
  338.          GOTO 180
  339.  170     CONTINUE
  340.          SEGSUP MTR6,MCHPOI,MTR3,MTR5
  341. C
  342. C     PB AVEC LES DIMENSIONS DES CHPOINTS
  343. C
  344.          CALL ERREUR(114)
  345.          IRET=0
  346.          RETURN
  347. *
  348.  180     CONTINUE
  349. *
  350.          N=N1
  351.          NC=mc
  352.          SEGINI MPOVAL
  353. C
  354. C     recopier le premier chpo
  355. C
  356.          DO 210 IC=1,NC1
  357.             if (nicom(ic).eq.0) then
  358.                DO 200 IB=1,N
  359.                   VPOCHA(IB,IC)=XXT1*MPOVA1.VPOCHA(IB,IC)
  360.  200           CONTINUE
  361.             endif
  362.  210     CONTINUE
  363. C
  364. C     rajouter le second
  365. C
  366.          ipt1=msoup1.igeoc
  367.          ipt2=msoup2.igeoc
  368. *  si les numerotations sont differentes il faut reordonner
  369.          if (ipt1.ne.ipt2) then
  370.             do 229 iel=1,ipt2.num(/2)
  371.                izon(ipt2.num(1,iel))=iel
  372.  229        continue
  373.             DO 230 IC=1,NC2
  374.                IIC=micom(ic)
  375.                if (iic.gt.nc1) then
  376.                   DO 221 IB=1,N
  377.                      VPOCHA(IB,IIC)=XXT2*
  378.      $                    MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC)
  379.  221              CONTINUE
  380.                else
  381.                   DO 220 IB=1,N
  382.                      VPOCHA(IB,IIC)=XXT1*mpova1.VPOCHA(IB,IIC)
  383.      $                    +XXT2*MPOVA2.VPOCHA(izon(ipt1.num(1,ib))
  384.      $                    ,IC)
  385.  220              CONTINUE
  386.                endif
  387.  230        CONTINUE
  388.          else
  389. *  meme pointeur geometrique on se passe de izon
  390.             DO 235 IC=1,NC2
  391.                IIC=micom(ic)
  392.                if (iic.gt.nc1) then
  393.                   DO 236 IB=1,N
  394.                      VPOCHA(IB,IIC)=XXT2*MPOVA2.VPOCHA(IB,IC)
  395.  236              CONTINUE
  396.                else
  397.                   DO 237 IB=1,N
  398.                      VPOCHA(IB,IIC)=XXT1*mpova1.VPOCHA(IB,IIC)+
  399.      >                    XXT2*MPOVA2.VPOCHA(IB,IC)
  400.  237              CONTINUE
  401.                endif
  402.  235        CONTINUE
  403.          endif
  404. C
  405.          SEGINI MSOUPO
  406.          DO 240 IB=1,NC
  407.             NOCOMP(IB)=mpcom(ib)
  408.             NOHARM(IB)=mphar(ib)
  409.  240     CONTINUE
  410.          IPOVAL=MPOVAL
  411.          IPT3=IPT1
  412.          IGEOC=IPT3
  413.          nposr=nposr+1
  414.          IPCHP(nposr)=MSOUPO
  415.          SEGSUP MTR6
  416.  250  CONTINUE
  417. *goo      SEGSUP MTR6
  418. *  il faut maintenant adjoindre les paquets de 1 pas dans 2 ou inversement
  419.       DO 251 IA=1,NSOUP1
  420.          if (ipos1(ia).ne.0) goto 251
  421.          nposr=nposr+1
  422.          msoupo=mchpo1.ipchp(ia)
  423.          segini,msoup1=msoupo
  424.          ipchp(nposr)=msoup1
  425.          mpoval=msoup1.ipoval
  426.          segact mpoval
  427.          n=vpocha(/1)
  428.          nc=vpocha(/2)
  429.          segini,mpova1
  430.          do 254 jb=1,nc
  431.             do 2541 ja=1,n
  432.                mpova1.vpocha(ja,jb)=xxt1*vpocha(ja,jb)
  433.  2541       continue
  434.  254     continue
  435.          msoup1.ipoval=mpova1
  436.  251  continue
  437.       DO 252 IB=1,NSOUP2
  438.          if (ipos2(ib).ne.0) goto 252
  439.          nposr=nposr+1
  440.          msoupo=mchpo2.ipchp(ib)
  441.          segini,msoup1=msoupo
  442.          ipchp(nposr)=msoup1
  443.          mpoval=msoup1.ipoval
  444.          segact mpoval
  445.          n=vpocha(/1)
  446.          nc=vpocha(/2)
  447.          segini,mpova1
  448.          do 253 jb=1,nc
  449.             do 2531 ja=1,n
  450.                mpova1.vpocha(ja,jb)=xxt2*vpocha(ja,jb)
  451.  2531       continue
  452.  253     continue
  453.          msoup1.ipoval=mpova1
  454.  252  continue
  455. *  verification que les composantes sont bien differentes entre paquets
  456.       do 255 isoupo=1,ipchp(/1)
  457.          msoup1=ipchp(isoupo)
  458.          SEGACT MSOUP1
  459.          nc1=msoup1.nocomp(/2)
  460.          do 256 jsoupo=isoupo+1,ipchp(/1)
  461.             msoup2=ipchp(jsoupo)
  462.             SEGACT MSOUP2
  463.             nc2=msoup2.nocomp(/2)
  464.             if (nc1.ne.nc2) goto 256
  465.             do 257 ic1=1,nc1
  466.                do 258 ic2=1,nc2
  467.                   if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2))
  468.      $                 goto 258
  469.                   if (msoup1.nocomp(ic1).eq.msoup2.nocomp(ic2))
  470.      $                 goto 257
  471.  258           continue
  472.                goto 256
  473.  257        continue
  474. *  pas de chance composantes en double
  475.             if (iimpi.eq.1954) write (ioimp,*)
  476.      $           ' pacquets en double => lent '
  477.             segsup mtr3,mtr5
  478.             goto 300
  479.  256     continue
  480.  255  continue
  481.       SEGSUP MTR3,MTR5
  482.  
  483.       RETURN
  484. C
  485. C *** CAS OU LES SUPPORTS GEOMETRIQUES NE SONT PAS IDENTIQUES
  486. C *** A UNE PERMUTATION PRES
  487. C
  488.  300  CONTINUE
  489. C
  490.       SEGINI MTRA,MTR1,MTR4
  491. C
  492.       MCHPOI=IPO1
  493.       SEGACT MCHPOI
  494.       MSOUPO=IPCHP(1)
  495.       SEGACT MSOUPO
  496.       IPCOM(**)=NOCOMP(1)
  497.       IPHAR(**)=NOHARM(1)
  498.       NC=1
  499.       IK=0
  500. C
  501. C     CREATION DE NOPOIN ET DE IPCOM
  502. C
  503.       DO 360 ICH=1,2
  504.          MCHPOI=IPO(ICH)
  505.          SEGACT MCHPOI
  506.          NSOUPO=IPCHP(/1)
  507. C
  508. C     BOUCLE SUR LES SOUS REFERENCES D 1 CHPOINT
  509. C
  510.          DO 350 IA=1,NSOUPO
  511.             MSOUPO=IPCHP(IA)
  512.             SEGACT MSOUPO
  513.             MELEME=IGEOC
  514.             SEGACT MELEME
  515.             NBELEM=NUM(/2)
  516.             DO 310 IB=1,NBELEM
  517.                K=NUM(1,IB)
  518.                IF(NOPOIN(K).NE.0) GO TO 310
  519.                IK=IK+1
  520.                NOPOIN(K)=IK
  521.  310        CONTINUE
  522.             NCBBB=NOCOMP(/2)
  523.             DO 330 IB=1,NCBBB
  524.                NC=IPCOM(/2)
  525.                DO 320 IC=1,NC
  526.                   IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320
  527.                   IF(IPHAR(IC).EQ.NOHARM(IB))  GO TO 330
  528.  320           CONTINUE
  529.                IPCOM(**)=NOCOMP(IB)
  530.                IPHAR(**)=NOHARM(IB)
  531.                NC=NC+1
  532.  330        CONTINUE
  533.  350     CONTINUE
  534.  360  CONTINUE
  535. C
  536.       NNIN=NC
  537.       NNNOE=IK
  538.       SEGINI MTRAV
  539. C
  540. C     CREATION DE INCO
  541. C
  542.       DO 380 IA=1,NNIN
  543.          INCO(IA)=IPCOM(IA)
  544.          NHAR(IA)=IPHAR(IA)
  545.  380  CONTINUE
  546. C
  547. C     CREATION DE BB,IBIN,IGEO
  548. C
  549.       MCHPOI=IPO(1)
  550.       SEGACT MCHPOI
  551.       NSOUPO=IPCHP(/1)
  552.       DO 1430 IA=1,NSOUPO
  553.          MSOUPO=IPCHP(IA)
  554.          SEGACT MSOUPO
  555.          MELEME=IGEOC
  556.          SEGACT MELEME
  557.          MPOVAL=IPOVAL
  558.          SEGACT MPOVAL
  559.          NBELEM=NUM(/2)
  560.          if (nbelem.ne.vpocha(/1)) then
  561.           call erreur(114)
  562.           iret=0
  563.          RETURN
  564.          endif
  565.          N=VPOCHA(/1)
  566.          NC=VPOCHA(/2)
  567.          NC1=NOCOMP(/2)
  568. C
  569.          DO 1420 IB=1,NC1
  570.             DO 1390 IC=1,NNIN
  571.                IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 1390
  572.                IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 1400
  573.  1390       CONTINUE
  574.  1400       CONTINUE
  575.             DO 1410 ID=1,NBELEM
  576.                KI=NOPOIN(NUM(1,ID))
  577.                IGEO(KI)=NUM(1,ID)
  578.                IBIN(IC,KI)=1
  579.                BB(IC,KI)=XXT1*VPOCHA(ID,IB)
  580.  1410       CONTINUE
  581.  1420    CONTINUE
  582.  1430 CONTINUE
  583.  
  584.       MCHPOI=IPO(2)
  585.       SEGACT MCHPOI
  586.       NSOUPO=IPCHP(/1)
  587.       DO 430 IA=1,NSOUPO
  588.          MSOUPO=IPCHP(IA)
  589.          SEGACT MSOUPO
  590.          MELEME=IGEOC
  591.          SEGACT MELEME
  592.          MPOVAL=IPOVAL
  593.          SEGACT MPOVAL
  594.          NBELEM=NUM(/2)
  595.          N=VPOCHA(/1)
  596.          NC=VPOCHA(/2)
  597.          NC1=NOCOMP(/2)
  598. C
  599.          DO 420 IB=1,NC1
  600.             DO 390 IC=1,NNIN
  601.                IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390
  602.                IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400
  603.  390        CONTINUE
  604.  400        CONTINUE
  605.             DO 410 ID=1,NBELEM
  606.                KI=NOPOIN(NUM(1,ID))
  607.                IGEO(KI)=NUM(1,ID)
  608.                IBIN(IC,KI)=1
  609.                BB(IC,KI)=BB(IC,KI)+XXT2*VPOCHA(ID,IB)
  610.  410        CONTINUE
  611.  420     CONTINUE
  612.  430  CONTINUE
  613.       ITRAV=MTRAV
  614. C
  615. C     RECONSTUCTION DE LA PARTITION
  616. C
  617.       CALL CRECHP(ITRAV,ICHPOI)
  618. C
  619.       SEGSUP MTRAV,MTRA,MTR1,MTR4
  620.       IRET   = ICHPOI
  621.       MCHPOI = ICHPOI
  622.       CALL COMBNA(IPO1,IPO2,INAT,IATTR)
  623.       NAT=INAT
  624.       NSOUPO = IPCHP(/1)
  625.       SEGADJ,MCHPOI
  626.       IRET  =MCHPOI
  627.       JATTRI(1)=IATTR
  628.       RETURN
  629.       END
  630.  
  631.  

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