Télécharger la plaquette Cast3M


fr en

Télécharger reduaf.eso

Retour à la liste

Numérotation des lignes : 

reduaf

  1. C REDUAF    SOURCE    PV090527  25/01/24    21:15:06     12111          
  2.  
  3. C  Reduction du champ par element jchelm sur le modele mmodtm
  4. C  Le resultat est le champ par element mchel2 pour iret = 1 (KERRE=0),
  5. C  sinon en cas d'erreur mchel2 = 0 pour iret = 0 (KERRE = num. erreur)
  6. C  En sortie le champ mchel2 est un champ entierement actif.
  7. C  (kich) en sortie mmodel deroule
  8.  
  9.       SUBROUTINE REDUAF (jchelm,mmodtm,mchel2,istri,iret,KERRE)
  10.  
  11.       IMPLICIT REAL*8(A-H,O-Z)
  12.       IMPLICIT INTEGER (I-N)
  13.  
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17.  
  18. -INC SMCHAML
  19. -INC SMMODEL
  20.  
  21. -INC SMCOORD
  22. -INC SMELEME
  23. -INC SMLENTI
  24. -INC CCPRECO
  25. -INC CCASSIS
  26.  
  27.       EXTERNAL LONG
  28.  
  29.       segment izone(NZ,NSMOD)
  30.       segment ismel(NZ,NSMOD)
  31.       segment szsxx
  32.         logical lzsxx(NZ,NSMOD)
  33.       endsegment
  34.  
  35.       segment icpr(nbpt)
  36.       segment inde(jg)
  37.  
  38.       CHARACTER*(NCONCH) conloc,MO24
  39.       CHARACTER*(LOCOMP) nomloc
  40.       CHARACTER*(16)     typloc
  41.       CHARACTER*(50)     typ1
  42.  
  43.  
  44.       LOGICAL BVALID,OOOVP1,dmopa
  45.  
  46.       itconf=0
  47.       goto 10
  48. *
  49.       ENTRY REDUAG (jchelm,mmodtm,mchel2,istri,iret,KERRE)
  50.       itconf=1
  51.   10  continue
  52.       melpv = 0
  53.       ith1  = oothrd + 1
  54.  
  55. CG      if (iimpi.eq.7203) then
  56. CG        write(ioimp,*) 'Entree dans reduaf',mmodtm,jchelm
  57. CG        call zpchel(jchelm,1)
  58. CG      endif
  59. c       write(6,*) 'Entree dans reduaf',jchelm,istri,mmodtm
  60.       CALL oooho2(ihcour)
  61.       iret   = 1
  62.       KERRE  = 0
  63.       mchel2 = 0
  64.       MO24   =' '
  65.  
  66.       IF(istri     .EQ. 0)THEN
  67. C       Extension du MMODEL en cas de modele de MELANGE et NON-STRICT
  68.         CALL MODETE(mmodtm,mmodel,IMELAN)
  69.       ELSEIF(istri .EQ. 1)THEN
  70.         mmodel = mmodtm
  71.       ELSE
  72.         CALL ERREUR(5)
  73.       ENDIF
  74.  
  75.       NSMOD  = mmodel.kmodel(/1)
  76.       DO is = 1, NSMOD
  77.         imodel = mmodel.kmodel(is)
  78. C       Verification si on a un modele de DARCY actuellement incompatible
  79. C       Car il se servent du MAILLAGE dans la TABLE DOMAINE et pas celui
  80. C       contenu dans le MMODEL
  81.         CALL PLACE(imodel.FORMOD,imodel.FORMOD(/2),IDARC,'DARCY')
  82.         IF (IDARC .NE. 0) THEN
  83.           mchel2=jchelm
  84.           RETURN
  85.         ENDIF
  86.       ENDDO
  87. *  verif configuration
  88.       mchelm=jchelm
  89.       segact mchelm
  90.       mclcn=mclcnf
  91. **    write(6,*) 'reduaf mchelm mclcn',mchelm,mclcn,itconf
  92.       if (itconf.eq.0.and.mclcn .ne.0.and.mclcn .ne.mcoord
  93.      > .and.titche.ne.'CARACTERISTIQUES' ) then 
  94.        moterr(1:8) = 'CHAMELEM'
  95.        interr(1) = mclcn 
  96.        interr(2) = mcoord
  97.        interr(3) = mchelm
  98.        if (.false.) then
  99.         call erreur(1149)
  100. **      ichaml(2**31)=1
  101.         return
  102.        endif
  103.       endif
  104. C ---------------------------------------------------------------------
  105. C     Preconditionnement de REDU
  106. C     Verification que le resultat n'est pas deja dans le CCPRECO
  107. C ---------------------------------------------------------------------
  108.       ITAILL = NBPRRE(ith1)
  109. ***   itaill=0
  110.       CALL oooho1(mmodel,IHOmmo)
  111.       CALL oooho1(jchelm,IHOjch)
  112.       DO 201 IPREC1 = 1, ITAILL
  113.         IF  (PRECMO(IPREC1,ith1) .NE. mmodel)       GOTO 201
  114.         IF ((PRECM1(IPREC1,ith1) .NE. jchelm) .AND.
  115.      &      (PRECM2(IPREC1,ith1) .NE. jchelm))      GOTO 201
  116.         IF  (PRECM3(IPREC1,ith1) .NE. istri )       GOTO 201
  117.  
  118. C       Ajout test horodatage du MMODEL et MCHAML d'entree (il a pu etre supprime puis recree avec le meme descripteur)
  119.         IF  (PRECM4(IPREC1,ith1) .NE. IHOmmo)       GOTO 201
  120.         IF  (PRECM5(IPREC1,ith1) .NE. IHOjch)       GOTO 201
  121.         IF  (PRECM6(IPREC1,ith1) .NE. mclcn )       GOTO 201
  122.  
  123.         mchel2 = PRECM2(IPREC1,ith1)
  124.         segact mchel2
  125. *  il faut que le preconditionnement soit sur la bonne configuration
  126.         if(mchel2.mclcnf.ne.mclcn) then
  127.           mchel2 = 0
  128.           goto 201
  129.         endif
  130.         IF(mchel2 .NE. jchelm) CALL ACTOBJ('MCHAML  ',mchel2,1+itconf)
  131. C        IF (IPREC1 .EQ. NPREDU) THEN
  132. C          PRINT *,' CCPRECO trop petit :',IPREC1
  133. C          CALL ERREUR(5)
  134. C        ENDIF
  135.  
  136. C       Mise a jour du preconditionnement dans CCPRECO : Deplacement en position 1 du REDU deja fait
  137.         IF (IPREC1 .EQ. 1) THEN
  138.           RETURN
  139.         ELSE
  140.           DO IPREC2 = IPREC1,2,-1
  141.             PRECMO(IPREC2,ith1) = PRECMO(IPREC2 - 1,ith1)
  142.             PRECM1(IPREC2,ith1) = PRECM1(IPREC2 - 1,ith1)
  143.             PRECM2(IPREC2,ith1) = PRECM2(IPREC2 - 1,ith1)
  144.             PRECM3(IPREC2,ith1) = PRECM3(IPREC2 - 1,ith1)
  145.             PRECM4(IPREC2,ith1) = PRECM4(IPREC2 - 1,ith1)
  146.             PRECM5(IPREC2,ith1) = PRECM5(IPREC2 - 1,ith1)
  147.             PRECM6(IPREC2,ith1) = PRECM6(IPREC2 - 1,ith1)
  148.           ENDDO
  149.           PRECMO(1,ith1) = mmodel
  150.           PRECM1(1,ith1) = jchelm
  151.           PRECM2(1,ith1) = mchel2
  152.           PRECM3(1,ith1) = istri
  153.           PRECM4(1,ith1) = IHOmmo
  154.           PRECM5(1,ith1) = IHOjch
  155.           PRECM6(1,ith1) = mclcn 
  156.           RETURN
  157.         ENDIF
  158.  201  CONTINUE
  159.  
  160. C 1   CONTINUE
  161.  
  162. C     Mise a jour du preconditionnement dans CCPRECO : Deplacement pour ecrire le nouveau REDU en 1ere position
  163.       ITAILL       = MIN(ITAILL + 1, NPREDU)
  164.       NBPRRE(ith1) = ITAILL
  165.       DO IPRECO = ITAILL,2,-1
  166.         PRECMO(IPRECO,ith1) = PRECMO(IPRECO - 1,ith1)
  167.         PRECM1(IPRECO,ith1) = PRECM1(IPRECO - 1,ith1)
  168.         PRECM2(IPRECO,ith1) = PRECM2(IPRECO - 1,ith1)
  169.         PRECM3(IPRECO,ith1) = PRECM3(IPRECO - 1,ith1)
  170.         PRECM4(IPRECO,ith1) = PRECM4(IPRECO - 1,ith1)
  171.         PRECM5(IPRECO,ith1) = PRECM5(IPRECO - 1,ith1)
  172.         PRECM6(IPRECO,ith1) = PRECM6(IPRECO - 1,ith1)
  173.       ENDDO
  174.       PRECMO(1,ith1) = mmodel
  175.       PRECM1(1,ith1) = jchelm
  176. C     PRECM2 doit etre mis a jour plus loin avant chaque RETURN
  177.       PRECM3(1,ith1) = istri
  178.       PRECM4(1,ith1) = IHOmmo
  179.       PRECM5(1,ith1) = IHOjch
  180.       PRECM6(1,ith1) = mclcn  
  181.  
  182.       mchelm = jchelm
  183.       NZ = mchelm.imache(/1)
  184.       L1 = mchelm.titche(/1)
  185.       N3 = mchelm.infche(/2)
  186.  
  187. C -----------------------------------------
  188. C Cas tres particulier de MCHELM resultat :
  189. C -----------------------------------------
  190.       IF (NZ.EQ.0) THEN
  191. CG      if (iimpi.eq.7203) write(ioimp,*) 'CAS PARTICULIER NZ = 0'
  192. C       Mise a jour du preconditionnement dans CCPRECO
  193.         mchel2         = jchelm
  194.         PRECM2(1,ith1) = jchelm
  195.         RETURN
  196.       ENDIF
  197.  
  198. C     Quelques initialisations :
  199. C     mlent2 contient le nombre d'elements du maillage de chaque sous-modele.
  200.       jg = NSMOD
  201.       call oooprl(1)
  202.       SEGINI,mlent2,izone,ismel,szsxx
  203.  
  204. C     mlent3 contient les intersections entre les maillages determinees :
  205. C     mlent3.lect(i3) avec ismel(iz,is) = i3 correspond a l'intersection
  206. C     entre le maillage du sous-modele is et la sous-zone iz du champ si
  207. C     la valeur de i3 n'est pas nulle !
  208.  
  209.       jg = NSMOD * NZ
  210.       SEGINI,mlent3
  211.       call oooprl(0)
  212.       NL3 = 0
  213.       ISOZM = 0
  214.  
  215.       icpr = 0
  216.       inde = 0
  217. C
  218. C Regroupement des zones directement appariees avec un sous-modele
  219. C Recherche des zones pouvant intersecter le maillage d'un sous-modele
  220.  
  221.       CALL ACTOBJ('MCHAML  ',mchelm,1+itconf)
  222.       DO 100 is = 1, NSMOD
  223.         imodel = mmodel.kmodel(is)
  224.         IF (imodel.nefmod.EQ.259) GOTO 100
  225.         meleme = imodel.imamod
  226.         CALL oooho1(meleme,IHO1)
  227.         itypm = meleme.itypel
  228.         mlent2.lect(is) = meleme.num(/2)
  229. C On parcourt tous les NZ chamelem elementaires.
  230.         DO 101 iz = 1, NZ
  231.           conloc = mchelm.conche(iz)
  232.           lzsxx(iz,is) = .false.
  233.  
  234.           IF (conloc.NE.MO24 .AND.
  235.      &        conloc     .NE.imodel.conmod(1:LCONMO)) GOTO 101
  236. C         PRINT *,'REDUAF:',is,iz,':',conloc,':',imodel.conmod,':'
  237.           ixx = 0
  238.           ipt1 = mchelm.imache(iz)
  239. C Correspondance maillage sous-zone et sous-modele
  240.           IF (ipt1.EQ.meleme) THEN
  241.             ixx = 1
  242.             lzsxx(iz,is) = .true.
  243. C Pas de correspondance directe, recherche intersection potentielle
  244.           ELSE
  245.             IF (ipt1.itypel.NE.itypm) GOTO 102
  246.  
  247.             CALL oooho1(ipt1,IHO2)
  248. C           Verification dans le PRECONDITIONNEMENT si deja evaluee
  249.             DO 400 III=1,NINTSA(ith1)
  250.               IF(PMAMOD(III,ith1) .NE. meleme) GOTO 400
  251.               IF(PMAMOH(III,ith1) .NE. IHO1  ) GOTO 400
  252.               IF(PMACHA(III,ith1) .NE. ipt1  ) GOTO 400
  253.               IF(PMACHH(III,ith1) .NE. IHO2  ) GOTO 400
  254.               mlenti=PMLENT(III,ith1)
  255. C             PRINT *,'REDUAF_PRECONDITION',oothrd,meleme,ipt1,mlenti
  256.  
  257. C              IF(mlenti .EQ. 0) THEN
  258. C                ixx = 0
  259. C                ismel(iz,is) = 0
  260. C
  261. C              ELSE
  262.                 NL3 = NL3 + 1
  263.                 mlent3.lect(NL3) = mlenti
  264.                 ixx = -1
  265.                 ismel(iz,is) = NL3
  266. C              ENDIF
  267.               GOTO 102
  268.  400        CONTINUE
  269.  
  270. C            PRINT *,'REDUAF_INTERSECTION',oothrd,meleme,ipt1
  271.  
  272. C On va regarder si on n a pas deja evalue l'intersection :
  273. C (meme sous-modele is et sous-zone precedente ia<iz)
  274.             DO ia = 1, iz-1
  275.               IF (ipt1.EQ.mchelm.imache(ia)) THEN
  276.                 IF (ismel(ia,is).GT.0) THEN
  277.                   ixx = -2
  278.                   ismel(iz,is) = ismel(ia,is)
  279.                   GOTO 102
  280.                 ENDIF
  281.               ENDIF
  282.             ENDDO
  283. C (meme sous-zone iz et sous-modele ia<is)
  284.             DO 103 ia = 1, is-1
  285.               imode2 = mmodel.kmodel(ia)
  286.               IF (imode2.nefmod.EQ.259) GOTO 103
  287.               ipt2 = imode2.imamod
  288.               IF (ipt2.EQ.meleme) THEN
  289.                 IF (ismel(iz,ia).GT.0) THEN
  290.                   ixx = -3
  291.                   ismel(iz,is) = ismel(iz,ia)
  292.                   GOTO 102
  293.                 ENDIF
  294.               ENDIF
  295.  103        CONTINUE
  296.  
  297.  
  298. C           Détermination de l'intersection de ipt1 et meleme :
  299. C           Creation d'un tableau (LISTENTI) de correspondance des
  300. C           elements de IPT1 qui sont dans MELEME
  301.             nbno1 = ipt1.num(/1)
  302.             nbel1 = ipt1.num(/2)
  303.             IF (icpr.EQ.0) THEN
  304.               nbpt = nbpts + 1
  305.               np1 = nbpt - 1
  306.               SEGINI,icpr
  307.             ELSE
  308.               DO j = 1, nbpt
  309.                 icpr(j) = 0
  310.               ENDDO
  311.             ENDIF
  312.             DO j = 1, nbel1
  313.               DO m = 1, nbno1
  314.                 ib = ipt1.num(m,j)
  315.                 icpr(ib) = icpr(ib) + 1
  316.               ENDDO
  317.             ENDDO
  318.             iprec = icpr(1)
  319.             DO j = 2, np1
  320.               iprec = iprec + icpr(j)
  321.               icpr(j) = iprec
  322.             ENDDO
  323.             jg = icpr(np1)
  324.             icpr(nbpt) = jg
  325.             IF (inde.EQ.0) THEN
  326.               SEGINI,inde
  327.             ELSE
  328.               IF (jg.GT.inde(/1)) THEN
  329.                 SEGADJ,inde
  330.               ENDIF
  331.               DO j = 1, jg
  332.                 inde(j) = 0
  333.               ENDDO
  334.             ENDIF
  335.             DO j = 1, nbel1
  336.               DO m = 1, nbno1
  337.                 ib = ipt1.num(m,j)
  338.                 ia = icpr(ib)
  339.                 inde(ia) = j
  340.                 icpr(ib) = ia - 1
  341.               ENDDO
  342.             ENDDO
  343.  
  344.  
  345. C           Fin du travail preparatoire pour le maillage ipt1
  346.             ipt2 = imodel.imamod
  347.             nbno2 = ipt2.num(/1)
  348.             nbel2 = ipt2.num(/2)
  349. c*          ipt2 = imodel.imamod = meleme
  350. c*          nbno2 = ipt2.num(/1) = nbno1
  351. c*          nbel2 = ipt2.num(/2) = mlent2.lect(is)
  352.  
  353.  
  354. C           on fabrique le mlenti de correspondance
  355. C           on dimensionne au nombre d elements de ipt2 = sous-modele is
  356.             jg = nbel2
  357.             SEGINI,mlenti
  358.             ibon = 0
  359.             DO 110 iel2 = 1, nbel2
  360.               ia = ipt2.num(1,iel2)
  361.               ideb = icpr(ia)+1
  362.               ifin = icpr(ia+1)
  363.               IF (ifin.LT.ideb) GOTO 110
  364.               DO 111 ib = ideb, ifin
  365.                 iel1 = inde(ib)
  366.                 DO j = 1, nbno1
  367.                   IF (ipt2.num(j,iel2).NE.ipt1.num(j,iel1)) GOTO 111
  368.                 ENDDO
  369.                 ibon = ibon + 1
  370.                 mlenti.lect(iel2) = iel1
  371.                 GOTO 110
  372.  111          CONTINUE
  373.  110        CONTINUE
  374.  
  375.             IF (ibon .EQ. 0) THEN
  376. C             Intersection VIDE entre MELEME et IPT1
  377.               ixx = 0
  378.               ismel(iz,is) = 0
  379.               SEGSUP,mlenti
  380.  
  381.             ELSE
  382. C             Intersection NON VIDE entre MELEME et IPT1
  383.               IF (ibon.GT.nbel1) THEN
  384. C               Si on a plus d'elements dans l'intersection que dans ipt1 !
  385.                 write(ioimp,*) 'REDUAF : Etiquette 11x intersection ?'
  386.               ENDIF
  387.               NL3 = NL3 + 1
  388.               mlent3.lect(NL3) = mlenti
  389.               ixx = -1
  390.               ismel(iz,is) = NL3
  391.             ENDIF
  392.  
  393. C           Ajout dans le PRECONDITIONNEMENT : Ajout a la suite
  394.             IF(mlenti .NE. 0)THEN
  395.               IPLACE=MOD(NINTSA(ith1),MIN(NTRIPL,max(1,NBESCR)))+1
  396. C             PRINT *,'REDUAF_AJOUT',oothrd,IPLACE,meleme,ipt1,mlenti
  397.               PMAMOD(IPLACE,ith1) = meleme
  398.               PMAMOH(IPLACE,ith1) = IHO1
  399.               PMACHA(IPLACE,ith1) = ipt1
  400.               PMACHH(IPLACE,ith1) = IHO2
  401.               PMLENT(IPLACE,ith1) = mlenti
  402.               NINTSA(ith1)        = IPLACE
  403.             ENDIF
  404.           ENDIF
  405. CG        write(*,*) '       -',iz,is,ixx,ismel(iz,is)
  406.  
  407.  
  408.  102      CONTINUE
  409. C         Sous-zone du mchelm a traiter
  410.           IF (ixx .NE. 0) THEN
  411.             DO 105 ia = 1, iz-1
  412.               ib = izone(ia,is)
  413.               IF (ib.EQ.0) GOTO 105
  414.               IF (conche(ia)(1:NCONCH).NE.conloc) GOTO 105
  415.               DO k = 1, N3
  416.                 IF (k.NE.4) THEN
  417.                   IF (infche(ia,k).NE.infche(iz,k)) GOTO 105
  418.                 ENDIF
  419.               ENDDO
  420.               izone(iz,is) = ib
  421.               GOTO 106
  422.  105        CONTINUE
  423.             ISOZM = ISOZM + 1
  424.             izone(iz,is) = ISOZM
  425.  106        CONTINUE
  426.           ENDIF
  427. CG        write(*,*) '       -',iz,is,ixx,izone(iz,is)
  428.  101    CONTINUE
  429.  100  CONTINUE
  430.  
  431.       IF (icpr.NE.0) SEGSUP,icpr
  432.       IF (inde.NE.0) SEGSUP,inde
  433.  
  434.  
  435.  
  436.  
  437. C ---------------------------------
  438. C Construction du MCHELM resultat :
  439. C ---------------------------------
  440. C     Grace au traitement ci-dessus (boucle 105), ISOZM correspond a N1 :
  441.       N1 = ISOZM
  442.       L1 = mchelm.titche(/1)
  443.       N3 = mchelm.infche(/2)
  444.  
  445.       CALL oooprl(1)
  446.       SEGINI,mchel2
  447.       mchel2.titche = mchelm.titche
  448.       mchel2.ifoche = mchelm.ifoche
  449.  
  450. C Pour chaque sous-modele "is", on regroupe les sous-zones du mchelm "iz"
  451. C associees (izone(iz,is) > 0) :
  452.       DO 200 is = 1, NSMOD
  453.         imodel = kmodel(is)
  454.         IF (imodel.nefmod.EQ.259) GOTO 200
  455.         ipt2  = imodel.imamod
  456.         nbel2 = mlent2.lect(is)
  457.  
  458.         DO 210 iz = 1, NZ
  459.           in1 = izone(iz,is)
  460.           IF (in1.LE.0) GOTO 210
  461.           mchaml = mchelm.ichaml(iz)
  462.           n21 = mchaml.ielval(/1)
  463.  
  464. C         Cas particulier du mchaml sans composante (on ne fait rien) :
  465.           IF (n21.EQ.0) GOTO 210
  466.  
  467.           IF (mchel2.imache(in1).EQ.0) THEN
  468. CG            write(ioimp,*) '  Cas 1 :',mchel2.imache(in1)
  469.             mchel2.conche(in1) = mchelm.conche(iz)
  470.             mchel2.imache(in1) = ipt2
  471.             DO k = 1, N3
  472.               mchel2.infche(in1,k) = mchelm.infche(iz,k)
  473.             ENDDO
  474.             n22 = 0
  475.             n2 = n22 + n21
  476.             SEGINI,mcham2
  477.             mchel2.ichaml(in1) = mcham2
  478.           ELSE
  479. CG            write(ioimp,*) '  Cas 2 :',mchel2.imache(in1)
  480.             mcham2 = mchel2.ichaml(in1)
  481.             n22 = mcham2.ielval(/1)
  482.             n2 = n22 + n21
  483.             SEGADJ,mcham2
  484.           ENDIF
  485.  
  486. *jk148537
  487. **        if (lzsxx(iz,is)) then
  488. **          do i = 1,n21
  489. **             mcham2.nomche(n22+i) = mchaml.nomche(i)
  490. **             mcham2.typche(n22+i) = mchaml.typche(i)
  491. **             mcham2.ielval(n22+i) = mchaml.ielval(i)
  492. **          enddo
  493. **          goto 210
  494. **        endif 
  495.  
  496.           mlenti = ismel(iz,is)
  497.           IF (mlenti.GT.0) mlenti = mlent3.lect(mlenti)
  498. CG          write(ioimp,*) '        :',iz,is,mlenti,n22,n21,n2
  499.           DO i = 1, n21
  500.             nomloc = mchaml.nomche(i)
  501.             iplac = 0
  502.             IF (n22.NE.0) THEN
  503.               CALL PLACE(mcham2.nomche(1),n22,iplac,nomloc)
  504.             ENDIF
  505.             typloc = mchaml.typche(i)
  506.             melval = mchaml.ielval(i)
  507.             nbpi1 = MAX(melval.velche(/1),melval.ielche(/1))
  508.             nbel1 = MAX(melval.velche(/2),melval.ielche(/2))
  509.             IF (nbel1.GT.1) nbel1 = nbel2
  510.  
  511.             IF (iplac.EQ.0) THEN
  512.               iplac = n22 + i
  513.               mcham2.nomche(iplac) = nomloc
  514.               mcham2.typche(iplac) = typloc
  515.               IF (typloc.EQ.'REAL*8          ') THEN
  516.                 n1ptel = nbpi1
  517.                 n1el   = nbel2
  518.                 n2ptel = 0
  519.                 n2el   = 0
  520.               ELSE
  521.                 n1ptel = 0
  522.                 n1el   = 0
  523.                 n2ptel = nbpi1
  524.                 n2el   = nbel2
  525.               ENDIF
  526.  
  527.               SEGINI,melva2
  528.               if (n1ptel.eq.0.and.n2ptel.eq.0) then
  529.                 call erreur(5)
  530.               endif
  531.               mcham2.ielval(iplac) = melva2
  532.             ELSE
  533. C             incompatibilite du type de composante entre champs
  534.               IF (mcham2.typche(iplac).NE.typloc) THEN
  535.                 KERRE = 917
  536.                 MOTERR(1:4)   = nomloc
  537.                 MOTERR(5:21)  = typloc
  538.                 MOTERR(22:38) = mcham2.typche(iplac)
  539.                 call oooprl(0)
  540.                 GOTO 9000
  541.               ENDIF
  542.               melva2 = mcham2.ielval(iplac)
  543. *  on duplique melva2 au cas ou il soit partage car on va le modifier
  544. **            segini,melva3=melva2
  545. **            mcham2.ielval(iplac)=melva3
  546.             ENDIF
  547.               melva2 = mcham2.ielval(iplac)
  548.  
  549. C           On ajoute melval a melva2 en tenant compte de l'intersection entre
  550. C           les maillages (mlenti = 0 si maillage identique, >0 sinon)
  551. C          "Extension" de melva2 si besoin par rapport a melval (appel a MELEXT)
  552. C           sera effectuee en prealable de l'addition des valeurs dans MELADD.
  553. C    si melva2 existait avant, on le duplique avant de le modifier
  554.           CALL oooho1(melva2,ihmelv)
  555.           if (ihmelv.ne.ihcour) then
  556.            segini,melva3=melva2
  557.            melva2=melva3
  558.            mcham2.ielval(iplac)=melva2
  559.           endif  
  560.             CALL MELADD(melva2,melval,typloc,mlenti,KERRE)
  561.             IF (KERRE.NE.0) then
  562.               GOTO 9000
  563.               call oooprl(0)
  564.             endif
  565.           ENDDO
  566. C
  567.  210    CONTINUE
  568.  200  CONTINUE
  569.  
  570. C Compactage du champ resultat :
  571. C ------------------------------
  572.       n1max = n1
  573.       n1 = 0
  574.       DO 310 i = 1, n1max
  575.         mcham2 = mchel2.ichaml(i)
  576.         IF (mcham2.EQ.0) GOTO 310
  577. C on compacte les composantes (s'il y en a bien sur !)
  578.         n22 = mcham2.ielval(/1)
  579.         IF (n22.EQ.0) GOTO 312
  580.         n2 = 0
  581.         DO 311 j = 1, n22
  582.           melva2 = mcham2.ielval(j)
  583.           IF (melva2.EQ.0) GOTO 311
  584.           CALL oooho1(melva2,ihmelv)
  585.           IF(ihmelv .EQ. ihcour)THEN
  586. C           Reduction seulement pour les SEGMENTS nouveaux !
  587.             CALL COMRED(melva2)
  588.           ENDIF
  589.           segact melva2
  590.           n2 = n2 + 1
  591.           mcham2.nomche(n2) = mcham2.nomche(j)
  592.           mcham2.typche(n2) = mcham2.typche(j)
  593.           mcham2.ielval(n2) = melva2
  594.  311    CONTINUE
  595.         IF (n2.EQ.0) GOTO 310
  596.         IF (n2.NE.n22) SEGADJ,mcham2
  597.  312    CONTINUE
  598.         n1 = n1 + 1
  599.         mchel2.conche(n1) = mchel2.conche(i)
  600.         mchel2.imache(n1) = mchel2.imache(i)
  601.         mchel2.ichaml(n1) = mcham2
  602.  
  603.         DO j = 1, N3
  604.           mchel2.infche(n1,j) = mchel2.infche(i,j)
  605.         ENDDO
  606.  310  CONTINUE
  607.       IF (n1.NE.n1max) SEGADJ,mchel2
  608.       CALL oooprl(0)
  609.  
  610.  
  611. C     Definition du type du MCHAML
  612. C     typ1 contient le nom du type identifie
  613. C     ltyp1 la longueur de la chaine de caractere
  614. C
  615.       CALL TYPCHL(mchel2,mmodtm,typ1,ltyp1)
  616.       IF (IERR.NE.0) RETURN
  617. C     Cas particuliers des modeles de modele (melange)
  618.       IF(ltyp1.NE.-2 .AND. ltyp1.GT.0 .and. mchel2.titche.eq.' ')THEN
  619.          IF (ltyp1 .NE. L1 ) THEN
  620.            L1=ltyp1
  621.            SEGADJ, mchel2
  622.          ENDIF
  623.          mchel2.titche=typ1
  624.       ENDIF
  625. C On sort un champ vide s'il n'y a pas de zone commune :
  626. c*      IF (n1.EQ.0) THEN
  627. c**G        if (iimpi.eq.7203) write(ioimp,*) 'N1 = 0 apres traitement'
  628. c*        KERRE = 21
  629. c*      ENDIF
  630.  
  631.  9000 CONTINUE
  632. C Destruction des segments de travail devenus inutiles :
  633.       SEGSUP,izone,ismel,mlent3,mlent2,szsxx
  634.  
  635.  9010 CONTINUE
  636.       IF (KERRE.NE.0) THEN
  637.         iret = 0
  638.         mchel2 = 0
  639.       ENDIF
  640.  
  641. CG    if (iimpi.eq.7203) then
  642. **    write(ioimp,*) 'Sortie de reduaf',mchel2,kerre
  643. **      if (kerre.eq.0) call zpchel(mchel2,1)
  644. CG    endif
  645.  
  646. C     Mise a jour du preconditionnement dans CCPRECO (Nouveau champ mchel2)
  647. ***   CALL ACTOBJ('MCHAML  ',mchel2,1+itconf)
  648.       PRECM2(1,ith1) = mchel2
  649.  
  650.       END
  651.  
  652.  
  653.  
  654.  
  655.  
  656.  

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