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

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