C FACED2 SOURCE PASCAL 21/02/11 21:15:11 10890 C TRACE D'ISOVALEUR EN COMMENCANT PAR CELLES DE DERRIERE C C SG 2016/07/18 Programmation comme faced, envvo2 pour gerer les faces TRI7/QUA9 C SUBROUTINE FACED2(MELEME,XPROJ,ICPR,VCHC,VCPCHA,PTI,NISO,IVU, # MCOUP,mcham,BLOK) * si mchaml est non nul on trace un chamelem aux noeuds * sinon c'est un champoint IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC CCGEOME -INC SMCHAML DIMENSION XX(13),YY(13),ZZ(13),VV(13) DIMENSION XR(3),YR(3),ZR(3),VR(3) SEGMENT XPROJ(3,1) SEGMENT ICPR(1) SEGMENT VCPCHA(nbpts) SEGMENT IPOI1(1,NPOI1) SEGMENT ISEG2(2,NSEG2) SEGMENT ISEG3(3,NSEG3) SEGMENT XPOI1(1,NPOI1) SEGMENT XSEG2(2,NSEG2) SEGMENT XSEG3(3,NSEG3) logical lmvid * * Type de faces prises en compte: T3, Q4, T6, Q8, POLY, T7, Q9 * Numero dans KDFAC 1 2 3 4 6 7 8 * Pour ne pas se prendre la tête, on numerote pareil que KDFAC * Pour les 5 (non utilisé), 6 (polygone) et >8, ca restera à 0 * NTYFAC=20, codé en dur dans CCGEOME pour KDFAC PARAMETER (NTYFAC=20) * Nb de faces de chaque type, sert également de compteur SEGMENT NBFAC(NTYFAC) * Un segment pointant sur les IFACI et les XFACI SEGMENT IPOFAC(2,NTYFAC) * Segment IFACI contenant les noeuds et si la face d'un * type donné est vue ou non SEGMENT IFACI(NNODE+1,NFACI) * Segment XFACI contenant les coordonnees noeuds, la couleur et si la face d'un * type donné est vue ou non SEGMENT XFACI(NNODE,NFACI) * Nombre de noeuds max pour les polygones PARAMETER (NNOMAX=14) * REAL BLOK * SEGMENT NSOMP(NFACP) SEGMENT TFAC(NFAC) SEGMENT KFAK(NFAC) SEGMENT NAUX(max(2,NFAC)) SEGMENT IVU(0) SEGMENT MCOUP(0) REAL VCHC DIMENSION VCHC(*) * Poids pour le calcul de la valeur centrale 6 valeurs TRI6 8 * valeurs QUA8. La somme des poids est egale a 1 PARAMETER (XUS3=1./3.,XMUS4=-0.25,XUS2=0.5) REAL XPOIDS(14) * TRI6 DATA XPOIDS/0.,XUS3,0.,XUS3,0.,XUS3, * QUA8 $ XMUS4,XUS2, XMUS4,XUS2, XMUS4,XUS2, XMUS4,XUS2/ * *dbg write(ioimp,*) 'coucou faced2 mcham=',mcham SEGACT MELEME * ipt1=lisous(1) * segact ipt1 * SEGACT XPROJ,ICPR MELSAU=MELEME IPT1=MELEME melval=ipt1 lmvid=.false. * write (6,*) ' faced2 velche ' * write (6,*) (velche(ix,1),ix=1,20) if (mcham.eq.0) then CALL ECROBJ('MAILLAGE',IPT1) CALL ENVELO CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) else CALL ENVEL1(ipt1,meleme,mcoup) endif IF (IERR.NE.0) RETURN SEGACT MELEME SEGACT XPROJ,ICPR NBPOIN=XPROJ(/2) TMIN=1E30 TMAX=-1E30 DO 1 I=1,NBPOIN TMIN=MIN(TMIN,XPROJ(3,I)) TMAX=MAX(TMAX,XPROJ(3,I)) 1 CONTINUE TDIST=TMAX-TMIN NPOI1=0 NSEG2=0 NSEG3=0 c c on compte le nombre d elements dont les faces sont de type 1 2 3 4 c 6 7 8 dans NBFAC, attention à 6 : gestion des polygones SEGINI NBFAC IPT1=MELEME SEGACT MELEME DO 10 IOB=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) SEGACT IPT1 ENDIF NBELEM=IPT1.NUM(/2) ILTEL=LTEL(1,IPT1.ITYPEL) IF (ILTEL.EQ.0) GOTO 12 ILTAD=LTEL(2,IPT1.ITYPEL) DO 13 IF=1,ILTEL IFT=LDEL(1,ILTAD+IF-1) NBFAC(IFT)=NBFAC(IFT)+NBELEM 13 CONTINUE 12 CONTINUE if (ipt1.itypel.eq.1) npoi1=npoi1+nbelem if (ipt1.itypel.eq.2) nseg2=nseg2+nbelem if (ipt1.itypel.eq.3) nseg3=nseg3+nbelem 10 CONTINUE * * WRITE(IOIMP,*) 'NBFAC' * WRITE (IOIMP,9111) (NBFAC(III),III=1,NTYFAC) * 9111 FORMAT(5(2X,I6)) NFACP=NBFAC(6) SEGINI NSOMP SEGINI ipoi1,iseg2,iseg3 if (mcham.ne.0) SEGINI xpoi1,xseg2,xseg3 c==== CREATION DES FACES ============================================== * Initialisation des IFACI,XFACI SEGINI IPOFAC DO ITYFAC=1,NTYFAC NNODE=KDFAC(1,ITYFAC) * Polygone IF (ITYFAC.EQ.6) NNODE=NNOMAX IF (NNODE.GT.0) THEN NFACI=NBFAC(ITYFAC) SEGINI IFACI IPOFAC(1,ITYFAC)=IFACI if (mcham.ne.0) then segini xfaci IPOFAC(2,ITYFAC)=xfaci endif ENDIF ENDDO NPOI1=0 NSEG2=0 NSEG3=0 c NBFAC sert maintenant de compteur DO ITYFAC=1,NTYFAC NBFAC(ITYFAC)=0 ENDDO ICOUPE=0 melval = meleme npasnul = 0 DO 50 IOB=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) ivm1=0 ivm2=0 melval=meleme if (mcham.ne.0) then melval=lisref(iob) if (melval.eq.0) then write (6,*) 'reference nulle dans faced2',iob goto 50 else npasnul = npasnul + 1 endif ivm1=velche(/1) ivm2=velche(/2) lmvid=(ivm1*ivm2.eq.0) *sg 2016/08/23 ancienne programmation brutale qui sort de la subroutine * sans mettre meleme=melsau => segmentation violation plus * tard * * if (ivm1*ivm2.eq.0) return endif ICOUPE=0 IF (IOB.EQ.LISOUS(/1).AND.MCOUP.NE.0) ICOUPE=1 ENDIF NBELEM=IPT1.NUM(/2) NBNN =IPT1.NUM(/1) ILTEL=LTEL(1,IPT1.ITYPEL) IF (ILTEL.EQ.0) GOTO 52 ILTAD=LTEL(2,IPT1.ITYPEL) DO 60 IF=1,ILTEL ITYFAC=LDEL(1,ILTAD+IF-1) IAD=LDEL(2,ILTAD+IF-1) NNODE=KDFAC(1,ITYFAC) NNODF=NNODE * Polygone IF (ITYFAC.EQ.6) THEN NBNN=IPT1.NUM(/1) * 23 1 *Erreur dans le module de trace IF (NBNN.GT.NNOMAX) THEN CALL ERREUR(23) RETURN ENDIF NNODE=NBNN NNODF=NNOMAX ENDIF IF (NNODE.GT.0) THEN * WRITE(IOIMP,*) 'ITYFAC=',ITYFAC IFACI=IPOFAC(1,ITYFAC) xfaci=IPOFAC(2,ITYFAC) * optimiseur if(xfaci.eq.0) xfaci=ipt1 DO 80 IEL=1,NBELEM * WRITE(IOIMP,*) 'IEL=',IEL do 70 inn=1,nbnn if (icpr(ipt1.num(inn,iel)).eq.0) then call erreur(23) goto 80 endif 70 continue NBFAC(ITYFAC)=NBFAC(ITYFAC)+1 j=NBFAC(ITYFAC) * Polygone IF (ITYFAC.EQ.6) NSOMP(j)=NNODE IFACI(NNODF+1,j)=1 DO i=1,NNODE IFACI(i,j)=IPT1.NUM(LFAC(IAD+i-1),IEL) if (mcham.ne.0.AND.(.not.lmvid)) then xfaci(i,j)=velche(min(ivm1,LFAC(IAD+i-1)), > min(ivm2,IEL)) * WRITE(IOIMP,*) 'INODE,IFACI,XFACI=',i,ifaci(i,j) * $ ,xfaci(i,j) endif IF (IVU(ICPR(IFACI(i,j))).NE.1) IFACI(NNODF+1,j)=0 ENDDO * TRI3 cas des coupes IF (ITYFAC.EQ.1) THEN IF (ICOUPE.EQ.1) THEN IF (MCOUP(IEL)/8.EQ.1) IFACI(NNODF+1,j)=2 IF (MCOUP(IEL)/16.EQ.1) IFACI(NNODF+1,j)=3 ENDIF ENDIF 80 CONTINUE ENDIF 60 CONTINUE IF (LISOUS(/1).NE.0) SEGDES IPT1 goto 50 52 CONTINUE do 68 iel=1,nbelem if (ipt1.itypel.eq.1) then npoi1=npoi1+1 IPOI1(1,NPOI1)=IPT1.NUM(1,IEL) elseif (ipt1.itypel.eq.2) then nseg2=nseg2+1 ISEG2(1,NSEG2)=IPT1.NUM(1,IEL) ISEG2(2,NSEG2)=IPT1.NUM(2,IEL) elseif (ipt1.itypel.eq.3) then nseg3=nseg3+1 ISEG3(1,NSEG3)=IPT1.NUM(1,IEL) ISEG3(2,NSEG3)=IPT1.NUM(2,IEL) ISEG3(3,NSEG3)=IPT1.NUM(3,IEL) endif if (mcham.ne.0.AND.(.not.lmvid)) then if (ipt1.itypel.eq.1) then xPOI1(1,NPOI1)=velche(min(ivm1,1),min(ivm2,IEL)) elseif (ipt1.itypel.eq.2) then xSEG2(1,NSEG2)=velche(min(ivm1,1),min(ivm2,IEL)) xSEG2(2,NSEG2)=velche(min(ivm1,2),min(ivm2,IEL)) elseif (ipt1.itypel.eq.3) then xSEG3(1,NSEG3)=velche(min(ivm1,1),min(ivm2,IEL)) xSEG3(2,NSEG3)=velche(min(ivm1,2),min(ivm2,IEL)) xSEG3(3,NSEG3)=velche(min(ivm1,3),min(ivm2,IEL)) endif endif 68 continue IF (LISOUS(/1).NE.0) SEGDES IPT1 50 CONTINUE SEGDES MELEME C SI que des pointeurs nuls dans LISREF : ERREUR IF (mcham.ne.0.AND.npasnul.EQ.0) THEN CALL ERREUR(23) RETURN ENDIF C IF FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES C PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON NFAC=0 DO ITYFAC=1,NTYFAC NFAC=NFAC+NBFAC(ITYFAC) ENDDO NFAC=NFAC+NPOI1+NSEG2+NSEG3 SEGINI TFAC,KFAK IFAC=0 ITYEL=0 * D'abord les faces ensuite les segments DO ITYFAC=1,NTYFAC NNODE=KDFAC(1,ITYFAC) IF (ITYFAC.EQ.6) THEN NNODF=NNOMAX ELSE NNODF=NNODE ENDIF IF (NNODE.GT.0.OR.ITYFAC.EQ.6) THEN IFACI=IPOFAC(1,ITYFAC) DO I=1,NBFAC(ITYFAC) IFAC=IFAC+1 * Polygone IF (ITYFAC.EQ.6) NNODE=NSOMP(I) XXXX = 0. DO J=1,NNODE XXXX = XXXX + XPROJ(3,ICPR(IFACI(J,I))) ENDDO XXXX=XXXX/NNODE TFAC(IFAC)=XXXX IF (IFACI(NNODF+1,I).EQ.1) TFAC(IFAC)=TFAC(IFAC)-TDIST KFAK(IFAC)=I+(ITYEL*NFAC) * TRI3/coupe IF (ITYFAC.EQ.1) THEN IF (IFACI(NNODF+1,I).EQ.2) $ TFAC(IFAC)=TFAC(IFAC)-2*TDIST IF (IFACI(NNODF+1,I).EQ.3) KFAK(IFAC)=0 ENDIF ENDDO ENDIF ITYEL=ITYEL+1 ENDDO DO I=1,NPOI1 IFAC=IFAC+1 TFAC(IFAC)=XPROJ(3,ICPR(IPOI1(1,I))) KFAK(IFAC)=I+(ITYEL*NFAC) ENDDO ITYEL=ITYEL+1 * SEG2 si NSEG2=0, la boucle est sautee DO I=1,NSEG2 IFAC=IFAC+1 TFAC(IFAC)=(XPROJ(3,ICPR(ISEG2(1,I)))+ $ XPROJ(3,ICPR(ISEG2(2,I))))/2. KFAK(IFAC)=I+(ITYEL*NFAC) *dbg write(ioimp,*) 'ifac,tfac,kfak=',ifac,tfac(ifac),kfak(ifac) ENDDO ITYEL=ITYEL+1 * SEG3 dans l'ancien faced2, il y avait /2. ???? DO I=1,NSEG3 IFAC=IFAC+1 TFAC(IFAC)=(XPROJ(3,ICPR(ISEG3(1,I)))+ # XPROJ(3,ICPR(ISEG3(2,I)))+ $ XPROJ(3,ICPR(ISEG3(3,I))))/3. KFAK(IFAC)=I+(ITYEL*NFAC) ENDDO C IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT TFAC *dbg WRITE (IOIMP,9111) (KFAK(I),TFAC(I),I=1,NFAC) 9111 FORMAT(5(2X,I6,1X,E12.5)) SEGINI NAUX IF (IDIM.EQ.2) GOTO 209 NAUX(1)=1 NAUX(2)=NFAC IZ=2 208 IZ=IZ-1 IF (IZ.LE.0) GOTO 209 IPB=NAUX(IZ*2-1) IPH=NAUX(IZ*2) IF(IPB.GE.IPH) GOTO 208 JPB=IPB-1 JPH=IPH+1 C CALCUL DU PIVOT PV=0. * DO 207 J=IPB,IPH * PV=PV+TFAC(J) *207 CONTINUE * PV=PV/(IPH-IPB+1) PV=(TFAC(IPB)+TFAC(IPH))/2. 242 JPB=JPB+1 IF (JPH.EQ.JPB) GOTO 245 IF (TFAC(JPB).LT.PV) GOTO 243 GOTO 242 243 JPH=JPH-1 IF (JPH.EQ.JPB) GOTO 245 IF (TFAC(JPH).GT.PV) GOTO 244 GOTO 243 244 IAUX=KFAK(JPB) KFAK(JPB)=KFAK(JPH) KFAK(JPH)=IAUX TAUX=TFAC(JPB) TFAC(JPB)=TFAC(JPH) TFAC(JPH)=TAUX GOTO 242 245 IF (JPB.GE.IPB) GOTO 247 JPB=JPB+1 JPH=JPH+2 GOTO 248 247 IF (JPH.LE.IPH) GOTO 249 JPB=JPB-2 JPH=JPH-1 GOTO 248 249 IF (TFAC(JPB).LE.PV) GOTO 250 IF (JPH.EQ.IPH) GOTO 251 252 JPH=JPH+1 GOTO 248 250 IF (JPB.EQ.IPB) GOTO 252 251 JPB=JPB-1 248 IF (JPB.EQ.IPB) GOTO 253 NAUX(2*IZ)=JPB IZ=IZ+1 253 IF (JPH.EQ.IPH) GOTO 208 NAUX(2*IZ)=IPH NAUX(2*IZ-1)=JPH IZ=IZ+1 GOTO 208 209 CONTINUE C LES FACES SONT CLASSEES DANS KFAK LES FACES ON ETE ELIMINEES PAR C ENVELO . IL NE RESTE PLUS QU'A TRACER *dbg WRITE (IOIMP,9111) (KFAK(I),TFAC(I),I=1,NFAC) DO 300 I=1,NFAC IFF=KFAK(I) IF (IFF.EQ.0) GOTO 300 IT=(IFF-1)/NFAC IF=IFF-IT*NFAC IT=IT+1 IOK=0 * ITYFAC=IT *dbg WRITE(IOIMP,*) 'IFAC,ITYFAC=',I,ITYFAC IF (ITYFAC.GE.1.AND.ITYFAC.LE.NTYFAC) THEN NNODE=KDFAC(1,ITYFAC) NNODF=NNODE * Polygone IF (ITYFAC.EQ.6) THEN NNODE=NSOMP(IF) NNODF=NNOMAX ENDIF * A cette etape on doit avoir nnode.gt.0 IF (NNODE.LE.0) THEN CALL ERREUR(5) RETURN ENDIF IFACI=IPOFAC(1,ITYFAC) xfaci=IPOFAC(2,ITYFAC) DO J=1,NNODE IF (IVU(ICPR(IFACI(J,IF))).EQ.1) IOK=1 ENDDO IF (IOK.EQ.1) THEN * Cas du TRI3 IF (ITYFAC.EQ.1) THEN DO J=1,NNODE NUPT=IFACI(J, IF) IDPT=ICPR(NUPT) XX(J)=XPROJ(1,IDPT) YY(J)=XPROJ(2,IDPT) ZZ(J)=XPROJ(3,IDPT) if (mcham.eq.0) then VV(J)=VCPCHA(NUPT) else VV(J)=xfaci(j,IF) endif ENDDO CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO) * Cas des autres faces. Elles ont pour particularité d'avoir une * valeur centrale et un contour, on trace avec TCISO par defaut * On peut aussi faire une boucle de TRISO mais ca donne un * Postscript plus gros. ELSE ICONT=0 ITCISO=1 * La valeur centrale est la moyenne sur les autres noeuds QUA4, POLY IF (ITYFAC.EQ.2.OR.ITYFAC.EQ.6) THEN XXM = 0. YYM = 0. ZZM = 0. VVM = 0. DO J=1,NNODE NUPT=IFACI(J, IF) IDPT=ICPR(NUPT) XXM = XPROJ(1,IDPT) + XXM YYM = XPROJ(2,IDPT) + YYM ZZM = XPROJ(3,IDPT) + ZZM IF (MCHAM.EQ.0) THEN VVM = VCPCHA(NUPT) + VVM ELSE VVM = xfaci(J, IF) + VVM ENDIF ENDDO XXM=XXM/NNODE YYM=YYM/NNODE ZZM=ZZM/NNODE VVM=VVM/NNODE * La valeur centrale est une moyenne pondérée ELSEIF (ITYFAC.EQ.3.OR.ITYFAC.EQ.4) THEN XXM = 0. YYM = 0. ZZM = 0. VVM = 0. IDEC=0 IF (ITYFAC.EQ.4) IDEC=6 DO J=1,NNODE NUPT=IFACI(J, IF) IDPT=ICPR(NUPT) XXM = XPROJ(1,IDPT)*XPOIDS(J+IDEC) + XXM YYM = XPROJ(2,IDPT)*XPOIDS(J+IDEC) + YYM ZZM = XPROJ(3,IDPT)*XPOIDS(J+IDEC) + ZZM IF (MCHAM.EQ.0) THEN VVM = VCPCHA(NUPT)*XPOIDS(J+IDEC) + VVM ELSE VVM = xfaci(J, IF)*XPOIDS(J+IDEC) + VVM ENDIF ENDDO * La valeur centrale est celle du dernier noeud (faces TRI7/QUA9) ELSEIF (ITYFAC.EQ.7.OR.ITYFAC.EQ.8) THEN * write(ioimp,*) 'coucou ityfac=',ityfac NUPT=IFACI(NNODE, IF) IDPT=ICPR(NUPT) XXM = XPROJ(1,IDPT) YYM = XPROJ(2,IDPT) ZZM = XPROJ(3,IDPT) IF (MCHAM.EQ.0) THEN VVM = VCPCHA(NUPT) * write(ioimp,*) 'vvm=',vvm ELSE VVM = xfaci(NNODE, IF) * write(ioimp,*) 'vvm=',vvm ENDIF * On met ICONT à 1 pour ne pas mettre le dernier noeud dans le contour ICONT=1 *!!! ITCISO=1 ELSE write(ioimp,*) 'ITYFAC=',ityfac,' non prevu' call erreur(5) return ENDIF XX(1)=XXM YY(1)=YYM ZZ(1)=ZZM VV(1)=VVM DO J=1,NNODE-ICONT JP=J+1 NUPT=IFACI(J, IF) IDPT=ICPR(NUPT) XX(JP) = XPROJ(1,IDPT) YY(JP) = XPROJ(2,IDPT) ZZ(JP) = XPROJ(3,IDPT) IF (MCHAM.EQ.0) THEN VV(JP) = VCPCHA(NUPT) ELSE VV(JP) = xfaci(J, IF) ENDIF ENDDO IF (ITCISO.EQ.1) THEN CALL TCISO(VCHC,XX,YY,ZZ,VV,NNODE-ICONT+1,NISO) ELSE XR(1)=XX(1) YR(1)=YY(1) ZR(1)=ZZ(1) VR(1)=VV(1) JMAX=NNODE-ICONT DO J=1,JMAX JP=J+1 IF (JP.GT.JMAX) JP=1 IA=J+1 IB=JP+1 XR(2)=XX(IA) YR(2)=YY(IA) ZR(2)=ZZ(IA) VR(2)=VV(IA) XR(3)=XX(IB) YR(3)=YY(IB) ZR(3)=ZZ(IB) VR(3)=VV(IB) CALL TRISO(VCHC,XR,YR,ZR,VR,3,NISO) ENDDO ENDIF ENDIF ENDIF * Cas des POI1 ELSEIF (ITYFAC.EQ.NTYFAC+1) THEN NNODE=2 IF (IVU(ICPR(IPOI1(1,IF))).EQ.1) IOK=1 IF (IOK.EQ.1) THEN NUPT=IPOI1(1,IF) IDPT=ICPR(NUPT) if (mcham.eq.0) then VV(1)=VCPCHA(NUPT) VV(2)=VV(1) else VV(1)=xpoi1(1,IF) VV(2)=VV(1) endif XX(1)=XPROJ(1,IDPT)+BLOK YY(1)=XPROJ(2,IDPT) ZZ(1)=XPROJ(3,IDPT) XX(2)=XPROJ(1,IDPT)-BLOK YY(2)=XPROJ(2,IDPT) ZZ(2)=XPROJ(3,IDPT) CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO) XX(1)=XPROJ(1,IDPT) YY(1)=XPROJ(2,IDPT)+BLOK ZZ(1)=XPROJ(3,IDPT) XX(2)=XPROJ(1,IDPT) YY(2)=XPROJ(2,IDPT)-BLOK ZZ(2)=XPROJ(3,IDPT) CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO) ENDIF * Cas des SEG2 ELSEIF (ITYFAC.EQ.NTYFAC+2) THEN NNODE=2 DO J=1,NNODE IF (IVU(ICPR(ISEG2(J,IF))).EQ.1) IOK=1 ENDDO IF (IOK.EQ.1) THEN DO J=1,NNODE NUPT=ISEG2(J, IF) IDPT=ICPR(NUPT) XX(J)=XPROJ(1,IDPT) YY(J)=XPROJ(2,IDPT) ZZ(J)=XPROJ(3,IDPT) if (mcham.eq.0) then VV(J)=VCPCHA(NUPT) else VV(J)=xseg2(j,IF) endif ENDDO CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO) ENDIF * Cas des SEG3 ELSEIF (ITYFAC.EQ.NTYFAC+3) THEN * 2 SEG2 ! DO ISEG=1,2 isegm=iseg-1 IOK=0 DO J=1,2 IF (IVU(ICPR(ISEG3(J+isegm,IF))).EQ.1) IOK=1 ENDDO IF (IOK.EQ.1) THEN DO J=1,2 NUPT=ISEG3(J+isegm, IF) IDPT=ICPR(NUPT) XX(J)=XPROJ(1,IDPT) YY(J)=XPROJ(2,IDPT) ZZ(J)=XPROJ(3,IDPT) if (mcham.eq.0) then VV(J)=VCPCHA(NUPT) else VV(J)=xseg3(j+isegm,IF) endif ENDDO CALL TRISO(VCHC,XX,YY,ZZ,VV,2,NISO) ENDIF ENDDO ELSE write(ioimp,*) 'ITYFAC=',ITYFAC,' non prevu' call erreur(5) return ENDIF 300 CONTINUE C 'EST FINI SEGACT MELEME IF (LISOUS(/1).NE.0) THEN NBSOUS=LISOUS(/1) IF (MCOUP.NE.0) NBSOUS=NBSOUS-1 DO 490 IO=1,NBSOUS IPT2=LISOUS(IO) segact ipt2 if (ipt2.itypel.gt.3.AND.ipt2.itypel.NE.32) then SEGSUP IPT2 if (mcham.ne.0) then melval=lisref(io) if (melval.ne.0) segsup melval endif else segdes ipt2 endif 490 CONTINUE ENDIF if (itypel.eq.0) SEGSUP MELEME MELEME=MELSAU SEGSUP TFAC,KFAK SEGSUP NAUX SEGSUP IPOI1,ISEG2,ISEG3 if (mcham.ne.0) SEGSUP XPOI1,XSEG2,XSEG3 SEGSUP NSOMP DO ITYFAC=1,NTYFAC IFACI=IPOFAC(1,ITYFAC) IF (IFACI.NE.0) THEN SEGSUP IFACI ENDIF xfaci=IPOFAC(2,ITYFAC) IF (XFACI.NE.0) THEN SEGSUP XFACI ENDIF ENDDO SEGSUP IPOFAC SEGSUP NBFAC RETURN END