C COCHPO SOURCE CB215821 20/11/25 13:21:39 10792 SUBROUTINE COCHPO(I0,I1,ITAI,ITAF) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C CE SUBROUTINE VERIFIE QUE LES CHPOINTI0 ET I1 SONT BIEN IDENTIQUE C C EVENTUELLEMENT IL REMET LA LISTE ITAI SOUS LA FORME CORRESPONDANT C C A I0 C C ECRIT PAR FARVACQUE C C APPELE PAR :FUSOLU C C APPELLE ERREUR(60) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C -INC SMELEME -INC PPARAM -INC CCOPTIO -INC SMCHPOI -INC SMSOLUT -INC SMCOORD C CHARACTER*(LOCOMP) ICOMP SEGMENT ICPR(nbpts) SEGMENT ICPRR(nbpts) SEGMENT ITRAV(4,NSOUP) SEGMENT ITRACO(NC) C C ITRAV(1,I)=NPOIN (NBRE DE POINTS DANS LE IEME SOUPO) C ITRAV(2,I)=J : AU MSOUPO I CORRESPOND LE MSOUP1 J C ITRAV(3,I)=0 : AUCUN CHANGEMENT A APPLIQUER AU MSOUPO I (SINON =1) C ITRAV(4,I)=ITRACO : CONTIENT LE POINTEUR DU SEGMENT ITRACO C CCC ITRACO(J)=K : LA COMPOSANTE A LA POSITION J DANS MCHPO1 EST A LA C CCC POSITION K DANS MCHPOI C CCC MCHPOI SERA LA CONFIGURATION FINALE C MCHPOI=I0 MCHPO1=I1 SEGACT MCHPO1,MCHPOI NSOUP=MCHPO1.IPCHP(/1) IF(NSOUP.EQ.IPCHP(/1)) GO TO 1 C LES 2 CHPOINTS DOIVENT AVOIR LE MEME NOMBRE DE SOUS CHAMPS CALL ERREUR(60) GO TO 5000 1 CONTINUE SEGINI ITRAV SEGINI ICPR SEGINI ICPRR ICPR1=nbpts DO 10 I=1,ICPR1 10 ICPR(I)=0 C C *** BOUCLE SUR LES SOUPO DE MCHPOI C *** DANS ICPR(I) ON MET LE NUMERO DU SOUPO OU SE TROUVE LE POINT I C *** ICPRR(I)=K SIGNIFIE QUE I EST LE KIEME POINT DU SOUPO C DO 2 I=1,NSOUP MSOUPO=IPCHP(I) SEGACT MSOUPO MELEME=IGEOC SEGACT MELEME NPOIN=NUM(/2) ITRAV(1,I)=NPOIN DO 3 IPP=1,NPOIN J=NUM(1,IPP) ICPR(J)=I ICPRR(J)=IPP 3 CONTINUE SEGDES MELEME,MSOUPO 2 CONTINUE C ICHPOI=MCHPOI CALL NUHARM(ICHPOI,IFO,IHAR) MCHPOI=ICHPOI C IFO=1 TOUTES LES HARMONIQUES SONT IDENTIQUES ... C ON PEUT METTRE ENSEMBLE DU MODE N ET DU MODE M C C*** BOUCLE SUR LES MSOUP1 DE MCHPO1 C DO 4 I=1,NSOUP MSOUP1=MCHPO1.IPCHP(I) SEGACT MSOUP1 MELEME=MSOUP1.IGEOC SEGACT MELEME NPOIN=NUM(/2) IP1=NUM(1,1) ISOUPO=ICPR(IP1) IF(ICPRR(IP1).NE.1) ITRAV(3,ISOUPO)=1 IF(ISOUPO.NE.0) GO TO 5 C POINT NON COMMUN AUX 2 CHPOINT CALL ERREUR(60) GO TO 5000 C 5 CONTINUE IF(NPOIN.EQ.ITRAV(1,ISOUPO)) GO TO 6 C LES 2 SOUPO N ONT PAS LE MEME NOMBRE DE POINTS CALL ERREUR(60) GO TO 5000 C 6 CONTINUE ITRAV(2,ISOUPO)=I IF(NPOIN.EQ.1) GO TO 9 DO 8 IPP=2,NPOIN IP1=NUM(1,IPP) IF(ICPRR(IP1).NE.IPP) ITRAV(3,ISOUPO)=1 IF(ICPR(IP1).EQ.ISOUPO)GO TO 8 C POINT NON COMMUN AUX 2 MSOUPO CALL ERREUR(60) GO TO 5000 8 CONTINUE 9 CONTINUE MSOUPO=IPCHP(ISOUPO) SEGACT MSOUPO NC=NOCOMP(/2) IF(MSOUP1.NOCOMP(/2).EQ.NC) GO TO 12 CALL ERREUR(60) C PAS LE MEME NOMBRE DE COMPOSANTE GO TO 5000 12 CONTINUE SEGINI ITRACO DO 13 IC=1,NC ICOMP=MSOUP1.NOCOMP(IC) IHARM=MSOUP1.NOHARM(IC) DO 14 ICC=1,NC IF(NOCOMP(ICC).NE.ICOMP) GO TO 14 IF(IFO.NE.1.AND.NOHARM(ICC).NE.IHARM) GO TO 14 IF(IC.NE.ICC)ITRAV(3,ISOUPO)=1 ITRACO(IC)=ICC GO TO 13 14 CONTINUE CALL ERREUR(60) C N ONT PAS LES MEMES COMPOSANTES GO TO 5000 13 CONTINUE ITRAV(4,ISOUPO)=ITRACO SEGDES ITRACO C SEGDES MSOUPO,MELEME,MSOUP1 4 CONTINUE SEGDES MCHPO1 C C DO 30 I=1,NSOUP IF(ITRAV(3,I).NE.0) GO TO 41 30 CONTINUE C IL N Y A AUCUNE MODIF A FAIRE SUR LES MPOVAL C DO 31 I=1,NSOUP IF(ITRAV(2,I).EQ.I) GO TO 31 GO TO 41 31 CONTINUE C IL N Y A AUCUNE MODIF A FAIRE ON SORT ITAF=ITAI GO TO 60 C 41 CONTINUE C *** SI IVAL=0 IL FAUT SEULEMENT PERMUTER LES MSOUP1 C *** SI IVAL=1 ON DOIT REMPLACER LES MSOUP1 PAR DES MSOUP2 C MSOLE1=ITAI SEGACT MSOLE1 LTAB=MSOLE1.ISOLEN(/1) N=LTAB SEGINI MSOLEN DO 42 IT=1,LTAB ISOLEN(IT)=MSOLE1.ISOLEN(IT) 42 CONTINUE SEGDES MSOLE1 C DO 50 IT=1,LTAB MCHPO1=ISOLEN(IT) SEGACT MCHPO1 NSOUPO=NSOUP NAT=MCHPO1.JATTRI(/1) SEGINI MCHPO2 MCHPO2.IFOPOI=IFOPOI * on reprend les meme attributs DO 101 INAT=1,NAT MCHPO2.JATTRI(INAT) = MCHPO1.JATTRI(INAT) 101 CONTINUE * DO 52 IS=1,NSOUPO MSOUP1=MCHPO1.IPCHP(ITRAV(2,IS)) IF(ITRAV(3,IS).NE.0) GO TO 53 MCHPO2.IPCHP(IS)=MSOUP1 GO TO 52 53 CONTINUE MSOUPO=IPCHP(IS) SEGACT MSOUPO,MSOUP1 NC=MSOUP1.NOCOMP(/2) SEGINI MSOUP2 MSOUP2.IGEOC=IGEOC DO 54 IC=1,NC MSOUP2.NOCOMP(IC)=NOCOMP(IC) MSOUP2.NOHARM(IC)=NOHARM(IC) IF(IFO.EQ.1) MSOUP2.NOHARM(IC)=MSOUP1.NOHARM(IC) 54 CONTINUE MELEME=MSOUP1.IGEOC SEGACT MELEME MPOVA1=MSOUP1.IPOVAL SEGACT MPOVA1 N=MPOVA1.VPOCHA(/1) NC=MPOVA1.VPOCHA(/2) SEGINI MPOVAL ITRACO=ITRAV(4,IS) SEGACT ITRACO DO 20 IN=1,N DO 20 IC=1,NC IP1=ICPRR(NUM(1,IN)) VPOCHA(IP1,ITRACO(IC))=MPOVA1.VPOCHA(IN,IC) 20 CONTINUE SEGDES ITRACO SEGDES MPOVA1,MPOVAL,MELEME MSOUP2.IPOVAL=MPOVAL SEGDES MSOUP2,MSOUP1,MSOUPO MCHPO2.IPCHP(IS)=MSOUP2 52 CONTINUE SEGDES MCHPO2,MCHPO1 ISOLEN(IT)=MCHPO2 50 CONTINUE SEGDES MSOLEN ITAF=MSOLEN C 60 CONTINUE DO 58 I=1,NSOUP ITRACO=ITRAV(4,I) SEGSUP ITRACO 58 CONTINUE SEGSUP ITRAV SEGSUP ICPR,ICPRR SEGDES MCHPOI 5000 CONTINUE RETURN END