C VARIPO SOURCE CB215821 20/11/25 13:42:07 10792 SUBROUTINE VARIPO(IPOI1,IPOI2,MOT2,IPOI3) C----------------------------------------------------------------------- C CHPOINT VARIABLE C----------------------------------------------------------------------- C ENTREES: C IPOI1=POINTEUR SUR UN CHPOINT C IPOI2=POINTEUR SUR UN EVOLUTIO C MOT2 =NOM DE COMPOSANTE A DONNER AU RESULTAT C SORTIE: C IPOI3=POINTEUR SUR LE CHPOINT RESULTAT C----------------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMCHPOI -INC SMEVOLL -INC SMLREEL -INC SMELEME CHARACTER*(*) MOT2 CHARACTER*(LOCOMP) MOTREF,MOTABS,MOTORD SEGMENT mwrk INTEGER ipoi(NBPTS) REAL*8 xpoi(NBPTS) ENDSEGMENT IPOI3 = 0 C C ON RECUPERE L'OBJET EVOLUTION C MEVOLL = IPOI2 SEGACT,MEVOLL KEVOLL = mevoll.IEVOLL(1) SEGDES,MEVOLL SEGACT,KEVOLL IF (kevoll.TYPX .NE. 'LISTREEL' .OR. & kevoll.TYPY .NE. 'LISTREEL') THEN SEGDES,KEVOLL MOTERR(1:8) = 'LISTREEL' CALL ERREUR(37) RETURN ENDIF MLREE1 = kevoll.IPROGX MLREE2 = kevoll.IPROGY MOTABS = kevoll.NOMEVX IF (MOT2.NE.' ') THEN MOTORD = MOT2 ELSE MOTORD = kevoll.NOMEVY(1:4) ENDIF SEGDES,KEVOLL * Petites verifications sur le contenu de l'evolution SEGACT,MLREE1,MLREE2 NBPOIX = MLREE1.PROG(/1) NBPOIY = MLREE2.PROG(/1) IF (NBPOIX.NE.NBPOIY) THEN CALL ERREUR(577) GOTO 999 ENDIF JORDO = 0 CALL VARIFV(MLREE1.PROG,NBPOIX, JORDO) IF (JORDO.EQ.0) THEN CALL ERREUR(872) GOTO 999 ENDIF C C ON RECUPERE LE CHPOINT C MCHPO1 = IPOI1 SEGACT,MCHPO1 C C Quelques verifications sur le CHPOINT d'entree NSOUP1 = MCHPO1.IPCHP(/1) C CHPOINT "VIDE" -> ERREUR IF (NSOUP1.LE.0) THEN MOTERR(1:8) = 'CHPOINT ' INTERR(1) = IPOI1 CALL ERREUR(356) GOTO 998 ENDIF C On active le CHPOINT d'entree (son entete) : C On regarde si on a une seule composante pour tout le champ. IBVAL = 0 DO 10 IA = 1, NSOUP1 MSOUP1 = MCHPO1.IPCHP(IA) SEGACT,MSOUP1 NC1 = MSOUP1.NOCOMP(/2) IF (NC1.EQ.1) THEN IBVAL = IBVAL + 1 IF (IBVAL.EQ.1) MOTREF = MSOUP1.NOCOMP(1) ENDIF 10 CONTINUE C Si le champ a plus d'une composante, on va rechercher celle qui C correspond a l'abscisse de l'evolution. IF (IBVAL.NE.NSOUP1) MOTREF = MOTABS C C "Petit" segment de travail : SEGINI,mwrk C C BOUCLE SUR LES SOUS-ZONES DU CHPOINT C NBPOI3 = 0 C DO 100 IA = 1, NSOUP1 C MSOUP1 = MCHPO1.IPCHP(IA) NC1 = MSOUP1.NOCOMP(/2) IF (NC1.LE.0) GOTO 100 IBVAL = 0 CALL PLACE(MSOUP1.NOCOMP(1),NC1,IBVAL,MOTREF) IF (IBVAL.LE.0) GOTO 100 MELEME = MSOUP1.IGEOC MPOVAL = MSOUP1.IPOVAL SEGACT,MELEME,MPOVAL NBNN = meleme.NUM(/1) NBELEM = meleme.NUM(/2) N = mpoval.VPOCHA(/1) NC = mpoval.VPOCHA(/2) C C Verification sur LES DIMENSIONS DU CHPOINT : C Ne devrait pas arriver sauf si le chpoint n'est pas bien cree par on C ne sait quel operateur ou operation ou autre bizarrerie... IF (N.NE.NBELEM .OR. NBNN.NE.1 .OR. NC1.NE.NC) THEN SEGDES,MELEME,MPOVAL MOTERR(1:8) = 'VARIPO' CALL ERREUR(178) CALL ERREUR(5) GOTO 997 ENDIF DO 110 IC = 1, N XTT1 = mpoval.VPOCHA(IC,IBVAL) CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,JORDO,XTT1, & YTT1) NBPOI3 = NBPOI3 + 1 C* Ici on ne verifie pas que le point n'a pas deja ete rencontre. mwrk.ipoi(NBPOI3) = meleme.NUM(1,IC) mwrk.xpoi(NBPOI3) = YTT1 110 CONTINUE SEGDES,MELEME,MPOVAL 100 CONTINUE C C ERREUR SI LA COMPOSANTE RECHERCHEE N'EST PAS DANS MCHPOI IF (NBPOI3.EQ.0) THEN MOTERR= MOTABS CALL ERREUR(181) GOTO 997 ENDIF C C ON REMPLIT LE CHPOINT DE SORTIE C NSOUPO = 1 NAT = MCHPO1.JATTRI(/1) SEGINI,MCHPOI mchpoi.MTYPOI = 'SCALAIRE' mchpoi.MOCHDE = 'CHPOINT cree par VARIPO' DO 200 IA = 1, NAT mchpoi.JATTRI(IA) = MCHPO1.JATTRI(IA) 200 CONTINUE mchpoi.IFOPOI = MCHPO1.IFOPOI NC = 1 SEGINI,MSOUPO mchpoi.IPCHP(1) = MSOUPO msoupo.NOCOMP(1)= MOTORD NBNN = 1 NBELEM = NBPOI3 NBSOUS = 0 NBREF = 0 SEGINI,MELEME meleme.ITYPEL = 1 N = NBPOI3 NC = 1 SEGINI,MPOVAL DO 210 IC = 1, NBPOI3 meleme.NUM(1,IC) = mwrk.ipoi(IC) mpoval.VPOCHA(IC,1) = mwrk.xpoi(IC) 210 CONTINUE CALL CRECH1(meleme,1) SEGDES,MELEME,MPOVAL msoupo.IGEOC = MELEME msoupo.IPOVAL = MPOVAL SEGDES,MSOUPO,MCHPOI IPOI3 = MCHPOI C C On ferme tous les segments restants (et on detruit les inutiles). 997 CONTINUE SEGSUP,mwrk DO 9970 IA = 1, NSOUP1 MSOUP1 = MCHPO1.IPCHP(IA) SEGDES,MSOUP1 9970 CONTINUE 998 CONTINUE SEGDES,MCHPO1 999 CONTINUE SEGDES,MLREE1,MLREE2 RETURN END