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

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