1 : C MSCHP1 SOURCE GOUNAND 12/08/01 22:29:15 7453 2 : SUBROUTINE MSCHP1(IPO2,IPO1,ICLE,IRET,ISOM) 3 : C======================================================================= 4 : C ENTREE 5 : C IPO1 = POINTEUR SUR LE PREMIER CHPO 6 : C IPO2 = POINTEUR SUR LE SECOND CHPO 7 : C ICLE = ENTIER CARACTERISANT LE TYPE DE COMPARAISON 8 : C ISOM = 1 SI ON VEUT LA SOMME, 0 SINON 9 : C SORTIE 10 : C IRET = POINTEUR SUR LE CHAMP RESULTAT SI ISOM=0 11 : C IRET = SOMME DES 1 ET DES 0 SI ISOM=1 12 : C======================================================================= 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8(A-H,O-Z) 15 : -INC SMCHPOI 16 : -INC CCOPTIO 17 : -INC SMELEME 18 : -INC SMCOORD 19 : -INC TMTRAV 20 : SEGMENT/MTRA/(NOPOIN(XCOOR(/1)/(IDIM+1))) 21 : SEGMENT MTR1 22 : CHARACTER*4 IPCOM(0) 23 : ENDSEGMENT 24 : SEGMENT/MTR4/(IPHAR(0)) 25 : CHARACTER*8 MOT 26 : KSOM=0 27 : C 28 : C POUR INFERIEUR, IDEM SUPERIEUR EN INVERSANT IPO1 ET IPO2 29 : C 30 : IF (ICLE.EQ.4.OR.ICLE.EQ.5) THEN 31 : IKKK=IPO2 32 : IPO2=IPO1 33 : IPO1=IKKK 34 : IF (ICLE.EQ.4) ICLE=2 35 : IF (ICLE.EQ.5) ICLE=1 36 : ENDIF 37 : C 38 : SEGINI MTRA,MTR1,MTR4 39 : C 40 : C MISE A ZERO DE NOPOIN 41 : C 42 : DO 10 IA=1,XCOOR(/1)/(IDIM+1) 43 : NOPOIN(IA)=0 44 : 10 CONTINUE 45 : C 46 : C CREATION DE NOPOIN ET DE IPCOM 47 : C 48 : MCHPOI=IPO2 49 : SEGACT MCHPOI 50 : IK=0 51 : NSOUPO=IPCHP(/1) 52 : C 53 : C BOUCLE SUR LES SOUS REFERENCES DU SECOND CHPO 54 : C 55 : DO 20 IA=1,NSOUPO 56 : MSOUPO=IPCHP(IA) 57 : SEGACT MSOUPO 58 : MELEME=IGEOC 59 : SEGACT MELEME 60 : NBNN=NUM(/1) 61 : NBELEM=NUM(/2) 62 : DO 30 IB=1,NBELEM 63 : K=NUM(1,IB) 64 : IF(NOPOIN(K).NE.0) GO TO 30 65 : IK=IK+1 66 : NOPOIN(K)=IK 67 : 30 CONTINUE 68 : SEGDES MELEME 69 : NCBBB=NOCOMP(/2) 70 : DO 40 IB=1,NCBBB 71 : NC=IPCOM(/2) 72 : DO 50 IC=1,NC 73 : IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 50 74 : IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 40 75 : 50 CONTINUE 76 : IPCOM(**)=NOCOMP(IB) 77 : IPHAR(**)=NOHARM(IB) 78 : 40 CONTINUE 79 : SEGDES MSOUPO 80 : 20 CONTINUE 81 : SEGDES MCHPOI 82 : C 83 : NNIN=IPCOM(/2) 84 : NNNOE=IK 85 : SEGINI MTRAV 86 : C 87 : C INITIALISATION A ZERO DES TABLEAUX 88 : C 89 : DO 60 IB=1,NNNOE 90 : DO 60 IA=1,NNIN 91 : BB(IA,IB)=0.D0 92 : IBIN(IA,IB)=0 93 : 60 CONTINUE 94 : C 95 : C CREATION DE INCO 96 : C 97 : DO 70 IA=1,NNIN 98 : INCO(IA)=IPCOM(IA) 99 : NHAR(IA)=IPHAR(IA) 100 : 70 CONTINUE 101 : C 102 : C CREATION DE BB,IBIN,IGEO A PARTIR DES VALEURS DU PREMIER CHPO 103 : C 104 : MCHPOI=IPO1 105 : SEGACT MCHPOI 106 : NSOUPO=IPCHP(/1) 107 : DO 80 IA=1,NSOUPO 108 : MSOUPO=IPCHP(IA) 109 : SEGACT MSOUPO 110 : MELEME=IGEOC 111 : SEGACT MELEME 112 : MPOVAL=IPOVAL 113 : SEGACT MPOVAL 114 : NBELEM=NUM(/2) 115 : N=VPOCHA(/1) 116 : NC=VPOCHA(/2) 117 : NC1=NOCOMP(/2) 118 : C 119 : DO 90 IB=1,NC1 120 : DO 100 IC=1,NNIN 121 : IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 100 122 : IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 110 123 : 100 CONTINUE 124 : C 125 : C ERREUR : PAS DE CORRESPONDANCE DES COMPOSANTES DES 2 CHPO 126 : C 126 : CALL ERREUR(488) 127 : SEGSUP MTRAV,MTRA,MTR1,MTR4 128 : SEGDES MCHPOI,MELEME,MSOUPO,MPOVAL 129 : RETURN 130 : 110 CONTINUE 131 : DO 120 ID=1,NBELEM 132 : KI=NOPOIN(NUM(1,ID)) 133 : IGEO(KI)=NUM(1,ID) 134 : IBIN(IC,KI)=1 135 : BB(IC,KI)=VPOCHA(ID,IB) 136 : 120 CONTINUE 137 : 90 CONTINUE 138 : SEGDES MELEME,MSOUPO,MPOVAL 139 : 80 CONTINUE 140 : SEGDES MCHPOI 141 : C 142 : C COMPARAISON PROPREMENT DITE 143 : C 144 : MCHPOI=IPO2 145 : SEGACT MCHPOI 146 : NSOUPO=IPCHP(/1) 147 : DO 130 IA=1,NSOUPO 148 : MSOUPO=IPCHP(IA) 149 : SEGACT MSOUPO 150 : MELEME=IGEOC 151 : SEGACT MELEME 152 : MPOVAL=IPOVAL 153 : SEGACT MPOVAL 154 : NBELEM=NUM(/2) 155 : N=VPOCHA(/1) 156 : NC=VPOCHA(/2) 157 : NC1=NOCOMP(/2) 158 : C 159 : DO 140 IB=1,NC1 160 : DO 150 IC=1,NNIN 161 : IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 150 162 : IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 160 163 : 150 CONTINUE 164 : 160 CONTINUE 165 : DO 170 ID=1,NBELEM 166 : KI=NOPOIN(NUM(1,ID)) 167 : IGEO(KI)=NUM(1,ID) 168 : IF(IBIN(IC,KI).NE.1) THEN 168 : CALL ERREUR(214) 169 : SEGSUP MTRAV,MTRA,MTR1,MTR4 170 : SEGDES MCHPOI,MELEME,MSOUPO,MPOVAL 171 : RETURN 172 : ENDIF 173 : IF(ISOM.EQ.0) THEN 174 : IF(ICLE.EQ.1) THEN 175 : IF(BB(IC,KI).GT.VPOCHA(ID,IB)) THEN 176 : BB(IC,KI)=1.D0 177 : ELSE 178 : BB(IC,KI)=0.D0 179 : ENDIF 180 : ELSEIF(ICLE.EQ.2) THEN 181 : IF(BB(IC,KI).GE.VPOCHA(ID,IB)) THEN 182 : BB(IC,KI)=1.D0 183 : ELSE 184 : BB(IC,KI)=0.D0 185 : ENDIF 186 : ELSEIF(ICLE.EQ.3) THEN 187 : IF(BB(IC,KI).EQ.VPOCHA(ID,IB)) THEN 188 : BB(IC,KI)=1.D0 189 : ELSE 190 : BB(IC,KI)=0.D0 191 : ENDIF 192 : ELSEIF(ICLE.EQ.6) THEN 193 : IF(BB(IC,KI).NE.VPOCHA(ID,IB)) THEN 194 : BB(IC,KI)=1.D0 195 : ELSE 196 : BB(IC,KI)=0.D0 197 : ENDIF 198 : ENDIF 199 : ELSEIF(ISOM.EQ.1) THEN 200 : IF(ICLE.EQ.1) THEN 201 : IF(BB(IC,KI).GT.VPOCHA(ID,IB)) KSOM=KSOM + 1 202 : ELSEIF(ICLE.EQ.2) THEN 203 : IF(BB(IC,KI).GE.VPOCHA(ID,IB)) KSOM=KSOM + 1 204 : ELSEIF(ICLE.EQ.3) THEN 205 : IF(BB(IC,KI).EQ.VPOCHA(ID,IB)) KSOM=KSOM + 1 206 : ELSEIF(ICLE.EQ.6) THEN 207 : IF(BB(IC,KI).NE.VPOCHA(ID,IB)) KSOM=KSOM + 1 208 : ENDIF 209 : ENDIF 210 : C 211 : 170 CONTINUE 212 : 140 CONTINUE 213 : SEGDES MELEME,MSOUPO,MPOVAL 214 : 130 CONTINUE 215 : SEGDES MCHPOI 216 : ITRAV=MTRAV 217 : SEGDES MTRAV 218 : IF(ISOM.EQ.1) THEN 219 : SEGSUP MTRAV,MTRA,MTR1,MTR4 220 : IRET=KSOM 221 : ELSE 222 : C 223 : C RECONSTUCTION DE LA PARTITION 224 : C 224 : CALL CRECHP(ITRAV,ICHPOI) 225 : C 226 : SEGSUP MTRAV,MTRA,MTR1,MTR4 227 : IRET=ICHPOI 228 : MCHPOI=ICHPOI 229 : MCHPO1=IPO1 230 : SEGACT MCHPOI*MOD 231 : SEGACT MCHPO1 232 : MOT=MCHPO1.MTYPOI 233 : MTYPOI=MOT 234 : NAT=MCHPO1.JATTRI(/1) 235 : NSOUPO=IPCHP(/1) 236 : SEGADJ MCHPOI 237 : DO 180 II=1,NAT 238 : JATTRI(II)=MCHPO1.JATTRI(II) 239 : 180 CONTINUE 240 : C 241 : SEGDES MCHPOI,MCHPO1 242 : ENDIF 243 : C 244 : RETURN 245 : END 246 : 247 : 248 : 249 :
© Cast3M 2003 - All rights reserved.
Disclaimer