C EVCHPO SOURCE GOUNAND 12/08/30 21:15:06 7490 SUBROUTINE EVCHPO(ICOUL) C====================================================================== C OPTION CHPO DE L'OPERATEUR EVOL C C C C LA SYNTHAXE DE CETTE OPTION D'EVOL EST LA SUIVANTE : C C C C C C EV1 = EVOL (COUL) CHPO CHPT COMP LIGN; C C C C C C + COUL : COULEUR DE LA COURBE (FACULTATIVE) C C C C + CHPT : CHAMP-POINT C C C C + COMP : COMPOSANTE DU CHAMP POINT C C C C + LIGN : LIGNE DE NOEUDS. C C C C C C====================================================================== IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC CCOPTIO -INC SMEVOLL -INC SMCHPOI -INC SMLREEL -INC SMELEME -INC SMCOORD -INC SMLMOTS -INC TMTRAV SEGMENT MVOL REAL*8 MMABS(JG) REAL*8 MMORD(JG) CHARACTER*4 NOMAB(JG) REAL*8 POSNO(JG) ENDSEGMENT SEGMENT TTRAV INTEGER ILIS(IDIMM) ENDSEGMENT CHARACTER*8 NOMQUA,NOM CHARACTER*4 CMOT CHARACTER*8 NCHPT,NMAIL CHARACTER*23 UMOT1 CHARACTER*16 UMOT2 CHARACTER*12 UMOT3 CHARACTER*72 TITRE REAL*8 DEPA(400),PREC(3),TREPA(400),MYPOS(3),HEPOS(3) LOGICAL FIRST,SECOND,THIRD,NOMME DIMENSION ITABCH(3) CMOT=' ' C LECTURE DES DIFFERENTES ENTREES C LECTURE DU CHAMP-POINT CALL LIROBJ ('CHPOINT',IBOPOI,1,IRETOC) IF (IRETOC.EQ.0) GOTO 111 MCHPOI=IBOPOI C LECTURE DE LA COMPOSANTE CALL LIRCHA(CMOT,0,IRETOU) C LECTURE DE L'OBJET MAILLAGE CALL LIROBJ('MAILLAGE',IPOI,1,IRETOM) IF (IRETOM.EQ.0) GOTO 111 MELEME = IPOI CALL LIGMAI(MELEME,TTRAV,1) IF(IERR.NE.0) RETURN SEGACT TTRAV NBNN=ILIS(/1) JG=NBNN SEGINI MVOL C APPEL A UNE ROUTINE DE PRESENTATION D'UN CHPOINT SOUS FORME RESUME CALL TRACHP(MCHPOI,MTRAV) SEGACT MTRAV SEGACT MCOORD ICC=0 NCO=INCO(/2) * IF(IRETOU.EQ.0.AND.NCO.GT.1) THEN MOTERR(1:8)='MOT ' CALL ERREUR(37) GO TO 111 ENDIF * * SI LE CHAMP A UNE SEULE COMPOSANTE ET QU'ON N'A PAS LU * DE NOM DE COMPOSANTE , ON LA PREND * IF(NCO.EQ.1.AND.IRETOU.EQ.0) THEN CMOT=INCO(1) ICC=1 ELSE DO 1 INC=1,NCO IF (INCO(INC).EQ.CMOT) THEN ICC=INC ENDIF 1 CONTINUE ENDIF * Pas besoin d'erreur, il suffit de mettre 0 * IF (ICC.EQ.0) THEN * MOTERR(1:4)=CMOT * CALL ERREUR(181) * GOTO 111 * ENDIF C BOUCLE SUR TOUS LES NOEUDS DU MAILLAGE IBAC=0 IBOC=0 ZMABS=0.D0 DO 2 IY=1,3 PREC(IY)=0.D0 2 CONTINUE DO 7 IBO=1,ILIS(/1) NN= ILIS(IBO) NCOO=0 DO 3 J=1,IDIM NCOO=NCOO+1 MYPOS(NCOO)=XCOOR((NN-1)*(IDIM+1)+NCOO) 3 CONTINUE TOTAL = 0.D0 DO 4 IT=1,IDIM TOTAL = TOTAL + (MYPOS(IT)-PREC(IT))**2 PREC(IT)=MYPOS(IT) 4 CONTINUE TOTAL = TOTAL**0.5D0 ZMABS = ZMABS + TOTAL IF (IBAC.EQ.0) THEN ZMABS=0.D0 ENDIF NOMME=.FALSE. CALL SKNAME(NN,NOMQUA,IRETOL,1) IF (IRETOL.EQ.1) THEN NOMME=.TRUE. NOM = NOMQUA ENDIF IF (ICC.EQ.0) THEN INDI0=1 ELSE INDI0=1 DO 6 KJ=1,IGEO(/1) NH=IGEO(KJ) IF(NH.EQ.NN) THEN IF (IBIN(ICC,KJ).EQ.0) THEN INDI0 = 1 GOTO 6 ENDIF IBAC=IBAC+1 MMORD(IBAC)=BB(ICC,KJ) MMABS(IBAC)=ZMABS INDI0=0 IF (NOMME) THEN IBOC=IBOC+1 POSNO (IBOC)=ZMABS NOMAB (IBOC)=NOM ENDIF GOTO 7 ENDIF 6 CONTINUE ENDIF IF (INDI0.EQ.1) THEN IBAC=IBAC+1 MMORD(IBAC)=0.D0 MMABS(IBAC)=ZMABS IF (NOMME) THEN IBOC=IBOC+1 POSNO (IBOC)=ZMABS NOMAB (IBOC)=NOM ENDIF ENDIF 7 CONTINUE JG=IBAC SEGINI MLREEL,MLREE1 DO 8 IT=1,IBAC PROG(IT)=MMABS(IT) MLREE1.PROG(IT)=MMORD(IT) 8 CONTINUE N=1 M=IBOC IF(M.NE.0) N = 2 SEGINI MEVOLL C C CREATION DU EVOL CONTENANT LES NOMS C IF(M.NE.0) THEN SEGINI KEVOLL *MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM IIIIIII * DANS NOMABS ON A LES POINTS QUALIFIES IIIIIII * IBOC LE NOMBRE DE POINTS QUALIFIES IIII * DANS POSNO LA POSITION DES POINTS QUALIFIES IIII * MLREEL : ABSCISSE DES POINTS IIII * MLREE1 : ORDONNEE DES POINTS IIIIII JGN=8 JGM=IBOC SEGINI MLMOTS JG=IBOC SEGINI MLREE2 IPROGX=MLREE2 IPROGY=MLMOTS TYPX='LISTREEL' TYPY='LISTMOTS' IEVOLL(2)=KEVOLL NUMEVY='MARQ' NUMEVX=ICOUL NOMEVX='ABS' NOMEVY=CMOT DO 9 I=1,IBOC MOTS(I)=NOMAB(I) MLREE2.PROG(I)=POSNO(I) 9 CONTINUE KEVTEX='POINTS NOMMES APPARTENANT A LA LIGNE' SEGDES MLREE2,MLMOTS,KEVOLL ENDIF SEGINI KEVOLL IEVOLL(1)= KEVOLL ITYEVO='REEL' TYPX='LISTREEL' TYPY='LISTREEL' IPROGX= MLREEL IPROGY= MLREE1 IEVTEX=TITREE NOMEVX= 'ABS' NOMEVY= CMOT NUMEVX= ICOUL NUMEVY= 'REEL' CALL SKNAME(IBOPOI,NCHPT,IRETO,0) IF (IRETO.NE.0) THEN CALL SKNAME(IPOI,NMAIL,IRETO,0) IF (IRETO.NE.0) THEN UMOT1= 'TRACE DE LA COMPOSANTE ' UMOT2= ' DU CHAMP-POINT ' UMOT3= ' LE LONG DE ' TITRE=UMOT1//CMOT//UMOT2//NCHPT//UMOT3//NMAIL KEVTEX=TITRE ENDIF ENDIF SEGDES MEVOLL,KEVOLL SEGDES MLREEL,MLREE1 CALL ECROBJ('EVOLUTIO',MEVOLL) SEGSUP MTRAV,TTRAV SEGSUP MVOL 111 RETURN END