1 : C COCHPO SOURCE CHAT 05/01/12 22:12:25 5004 2 : SUBROUTINE COCHPO(I0,I1,ITAI,ITAF) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 6 : C C CE SUBROUTINE VERIFIE QUE LES CHPOINTI0 ET I1 SONT BIEN IDENTIQUE 7 : C C EVENTUELLEMENT IL REMET LA LISTE ITAI SOUS LA FORME CORRESPONDANT 8 : C C A I0 9 : C C ECRIT PAR FARVACQUE 10 : C C APPELE PAR :FUSOLU 11 : C C APPELLE ERREUR(60) 12 : C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 13 : C 14 : -INC SMELEME 15 : -INC CCOPTIO 16 : -INC SMCHPOI 17 : -INC SMSOLUT 18 : -INC SMCOORD 19 : C 20 : CHARACTER*4 ICOMP 21 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 22 : SEGMENT ICPRR(XCOOR(/1)/(IDIM+1)) 23 : SEGMENT ITRAV(4,NSOUP) 24 : SEGMENT ITRACO(NC) 25 : C 26 : C ITRAV(1,I)=NPOIN (NBRE DE POINTS DANS LE IEME SOUPO) 27 : C ITRAV(2,I)=J : AU MSOUPO I CORRESPOND LE MSOUP1 J 28 : C ITRAV(3,I)=0 : AUCUN CHANGEMENT A APPLIQUER AU MSOUPO I (SINON =1) 29 : C ITRAV(4,I)=ITRACO : CONTIENT LE POINTEUR DU SEGMENT ITRACO 30 : C CCC ITRACO(J)=K : LA COMPOSANTE A LA POSITION J DANS MCHPO1 EST A LA 31 : C CCC POSITION K DANS MCHPOI 32 : C CCC MCHPOI SERA LA CONFIGURATION FINALE 33 : C 34 : MCHPOI=I0 35 : MCHPO1=I1 36 : SEGACT MCHPO1,MCHPOI 37 : NSOUP=MCHPO1.IPCHP(/1) 38 : IF(NSOUP.EQ.IPCHP(/1)) GO TO 1 39 : C LES 2 CHPOINTS DOIVENT AVOIR LE MEME NOMBRE DE SOUS CHAMPS 39 : CALL ERREUR(60) 40 : GO TO 5000 41 : 1 CONTINUE 42 : SEGINI ITRAV 43 : SEGINI ICPR 44 : SEGINI ICPRR 45 : ICPR1=XCOOR(/1)/(IDIM+1) 46 : DO 10 I=1,ICPR1 47 : 10 ICPR(I)=0 48 : C 49 : C *** BOUCLE SUR LES SOUPO DE MCHPOI 50 : C *** DANS ICPR(I) ON MET LE NUMERO DU SOUPO OU SE TROUVE LE POINT I 51 : C *** ICPRR(I)=K SIGNIFIE QUE I EST LE KIEME POINT DU SOUPO 52 : C 53 : DO 2 I=1,NSOUP 54 : MSOUPO=IPCHP(I) 55 : SEGACT MSOUPO 56 : MELEME=IGEOC 57 : SEGACT MELEME 58 : NPOIN=NUM(/2) 59 : ITRAV(1,I)=NPOIN 60 : DO 3 IPP=1,NPOIN 61 : J=NUM(1,IPP) 62 : ICPR(J)=I 63 : ICPRR(J)=IPP 64 : 3 CONTINUE 65 : SEGDES MELEME,MSOUPO 66 : 2 CONTINUE 67 : C 68 : 69 : ICHPOI=MCHPOI 69 : CALL NUHARM(ICHPOI,IFO,IHAR) 70 : MCHPOI=ICHPOI 71 : C IFO=1 TOUTES LES HARMONIQUES SONT IDENTIQUES ... 72 : C ON PEUT METTRE ENSEMBLE DU MODE N ET DU MODE M 73 : C 74 : C*** BOUCLE SUR LES MSOUP1 DE MCHPO1 75 : C 76 : DO 4 I=1,NSOUP 77 : MSOUP1=MCHPO1.IPCHP(I) 78 : SEGACT MSOUP1 79 : MELEME=MSOUP1.IGEOC 80 : SEGACT MELEME 81 : NPOIN=NUM(/2) 82 : IP1=NUM(1,1) 83 : ISOUPO=ICPR(IP1) 84 : IF(ICPRR(IP1).NE.1) ITRAV(3,ISOUPO)=1 85 : IF(ISOUPO.NE.0) GO TO 5 86 : C POINT NON COMMUN AUX 2 CHPOINT 86 : CALL ERREUR(60) 87 : GO TO 5000 88 : C 89 : 5 CONTINUE 90 : IF(NPOIN.EQ.ITRAV(1,ISOUPO)) GO TO 6 91 : C LES 2 SOUPO N ONT PAS LE MEME NOMBRE DE POINTS 91 : CALL ERREUR(60) 92 : GO TO 5000 93 : C 94 : 6 CONTINUE 95 : ITRAV(2,ISOUPO)=I 96 : IF(NPOIN.EQ.1) GO TO 9 97 : DO 8 IPP=2,NPOIN 98 : IP1=NUM(1,IPP) 99 : IF(ICPRR(IP1).NE.IPP) ITRAV(3,ISOUPO)=1 100 : IF(ICPR(IP1).EQ.ISOUPO)GO TO 8 101 : C POINT NON COMMUN AUX 2 MSOUPO 101 : CALL ERREUR(60) 102 : GO TO 5000 103 : 8 CONTINUE 104 : 9 CONTINUE 105 : MSOUPO=IPCHP(ISOUPO) 106 : SEGACT MSOUPO 107 : NC=NOCOMP(/2) 108 : IF(MSOUP1.NOCOMP(/2).EQ.NC) GO TO 12 108 : CALL ERREUR(60) 109 : C PAS LE MEME NOMBRE DE COMPOSANTE 110 : GO TO 5000 111 : 12 CONTINUE 112 : SEGINI ITRACO 113 : DO 13 IC=1,NC 114 : ICOMP=MSOUP1.NOCOMP(IC) 115 : IHARM=MSOUP1.NOHARM(IC) 116 : DO 14 ICC=1,NC 117 : IF(NOCOMP(ICC).NE.ICOMP) GO TO 14 118 : IF(IFO.NE.1.AND.NOHARM(ICC).NE.IHARM) GO TO 14 119 : IF(IC.NE.ICC)ITRAV(3,ISOUPO)=1 120 : ITRACO(IC)=ICC 121 : GO TO 13 122 : 14 CONTINUE 122 : CALL ERREUR(60) 123 : C N ONT PAS LES MEMES COMPOSANTES 124 : GO TO 5000 125 : 13 CONTINUE 126 : ITRAV(4,ISOUPO)=ITRACO 127 : SEGDES ITRACO 128 : C 129 : SEGDES MSOUPO,MELEME,MSOUP1 130 : 4 CONTINUE 131 : SEGDES MCHPO1 132 : C 133 : C 134 : DO 30 I=1,NSOUP 135 : IF(ITRAV(3,I).NE.0) GO TO 41 136 : 30 CONTINUE 137 : C IL N Y A AUCUNE MODIF A FAIRE SUR LES MPOVAL 138 : C 139 : DO 31 I=1,NSOUP 140 : IF(ITRAV(2,I).EQ.I) GO TO 31 141 : GO TO 41 142 : 31 CONTINUE 143 : C IL N Y A AUCUNE MODIF A FAIRE ON SORT 144 : ITAF=ITAI 145 : GO TO 60 146 : C 147 : 41 CONTINUE 148 : C *** SI IVAL=0 IL FAUT SEULEMENT PERMUTER LES MSOUP1 149 : C *** SI IVAL=1 ON DOIT REMPLACER LES MSOUP1 PAR DES MSOUP2 150 : C 151 : MSOLE1=ITAI 152 : SEGACT MSOLE1 153 : LTAB=MSOLE1.ISOLEN(/1) 154 : N=LTAB 155 : SEGINI MSOLEN 156 : DO 42 IT=1,LTAB 157 : ISOLEN(IT)=MSOLE1.ISOLEN(IT) 158 : 42 CONTINUE 159 : SEGDES MSOLE1 160 : C 161 : DO 50 IT=1,LTAB 162 : MCHPO1=ISOLEN(IT) 163 : SEGACT MCHPO1 164 : NSOUPO=NSOUP 165 : NAT=MCHPO1.JATTRI(/1) 166 : SEGINI MCHPO2 167 : MCHPO2.IFOPOI=IFOPOI 168 : * on reprend les meme attributs 169 : DO 101 INAT=1,NAT 170 : MCHPO2.JATTRI(INAT) = MCHPO1.JATTRI(INAT) 171 : 101 CONTINUE 172 : * 173 : DO 52 IS=1,NSOUPO 174 : MSOUP1=MCHPO1.IPCHP(ITRAV(2,IS)) 175 : IF(ITRAV(3,IS).NE.0) GO TO 53 176 : MCHPO2.IPCHP(IS)=MSOUP1 177 : GO TO 52 178 : 53 CONTINUE 179 : MSOUPO=IPCHP(IS) 180 : SEGACT MSOUPO,MSOUP1 181 : NC=MSOUP1.NOCOMP(/2) 182 : SEGINI MSOUP2 183 : MSOUP2.IGEOC=IGEOC 184 : DO 54 IC=1,NC 185 : MSOUP2.NOCOMP(IC)=NOCOMP(IC) 186 : MSOUP2.NOHARM(IC)=NOHARM(IC) 187 : IF(IFO.EQ.1) MSOUP2.NOHARM(IC)=MSOUP1.NOHARM(IC) 188 : 54 CONTINUE 189 : MELEME=MSOUP1.IGEOC 190 : SEGACT MELEME 191 : MPOVA1=MSOUP1.IPOVAL 192 : SEGACT MPOVA1 193 : N=MPOVA1.VPOCHA(/1) 194 : NC=MPOVA1.VPOCHA(/2) 195 : SEGINI MPOVAL 196 : ITRACO=ITRAV(4,IS) 197 : SEGACT ITRACO 198 : DO 20 IN=1,N 199 : DO 20 IC=1,NC 200 : IP1=ICPRR(NUM(1,IN)) 201 : VPOCHA(IP1,ITRACO(IC))=MPOVA1.VPOCHA(IN,IC) 202 : 20 CONTINUE 203 : SEGDES ITRACO 204 : SEGDES MPOVA1,MPOVAL,MELEME 205 : MSOUP2.IPOVAL=MPOVAL 206 : SEGDES MSOUP2,MSOUP1,MSOUPO 207 : MCHPO2.IPCHP(IS)=MSOUP2 208 : 52 CONTINUE 209 : SEGDES MCHPO2,MCHPO1 210 : ISOLEN(IT)=MCHPO2 211 : 50 CONTINUE 212 : SEGDES MSOLEN 213 : ITAF=MSOLEN 214 : C 215 : 60 CONTINUE 216 : DO 58 I=1,NSOUP 217 : ITRACO=ITRAV(4,I) 218 : SEGSUP ITRACO 219 : 58 CONTINUE 220 : SEGSUP ITRAV 221 : SEGSUP ICPR,ICPRR 222 : SEGDES MCHPOI 223 : 5000 CONTINUE 224 : RETURN 225 : END 226 :
© Cast3M 2003 - All rights reserved.
Disclaimer