1 : C MANUC8 SOURCE CHAT 11/06/17 21:15:01 7010 2 : SUBROUTINE MANUC8 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : -INC CCGEOME 6 : -INC CCOPTIO 7 : -INC SMCHAML 8 : -INC SMLREEL 9 : -INC SMEVOLL 10 : -INC SMTABLE 11 : * attention la dimension de infos doit etre suppereiur a 12 : * deuxieme dimension de infche 13 : dimension infos(20) 14 : SEGMENT IDONN 15 : REAL*8 XABS(NDI) 16 : INTEGER IPC(NDI) 17 : ENDSEGMENT 18 : SEGMENT ITAFF 19 : INTEGER JTAFF(NNSO,NNCH) 20 : ENDSEGMENT 21 : CHARACTER*72 MOT 22 : CHARACTER*16 CONCH1,CONCH2 23 : CHARACTER*16 NCOPO,NOMCH1 24 : * 25 : * LECTURE DES DONNEES 26 : * 26 : CALL LIRCHA(NCOPO,1,ILO) 27 : IF(IERR.NE.0) RETURN 28 : * 29 : * LECTURE EVENTUELLE D'UNE TABLE et traitement 30 : * 30 : CALL LIROBJ('TABLE ',MTABLE,0,IRETOU) 31 : IF(IRETOU.NE.0) THEN 32 : SEGACT MTABLE 33 : NDI = MLOTAB 34 : SEGINI IDONN 35 : NVR=0 36 : DO 7003 I=1,MLOTAB 37 : IF(MTABTI(I).NE.'ENTIER '.AND.MTABTI(I).NE.'FLOTTANT') 38 : $ GO TO 7003 39 : IF(MTABTV(I).NE.'MCHAML ') GO TO 7003 40 : NVR=NVR+1 41 : IF(MTABTI(I).EQ.'ENTIER ') THEN 42 : XABS(NVR)=MTABII(I) 43 : ELSE 44 : XABS(NVR)= RMTABI(I) 45 : ENDIF 46 : IPC(NVR)=MTABIV(I) 47 : 7003 CONTINUE 48 : NDI=NVR 49 : IF(NDI.NE.MLOTAB) SEGADJ IDONN 50 : ELSE 51 : * 52 : * LECTURE DES COUPLES ( FLOT MCHAML) 53 : * 54 : NVR=0 55 : NDI=20 56 : SEGINI IDONN 57 : 7001 CONTINUE 57 : CALL LIRREE(XVAL,0,IRETOU) 58 : IF( IRETOU.EQ.0) GO TO 7002 58 : CALL LIROBJ('MCHAML ',IPCH,1,IRETOU) 59 : IF(IERR.NE.0) RETURN 60 : NVR=NVR+1 61 : IF(NVR.GT.NDI) THEN 62 : NDI = NDI +20 63 : SEGADJ IDONN 64 : ENDIF 65 : XABS(NVR)=XVAL 66 : IPC(NVR)=IPCH 67 : GO TO 7001 68 : 7002 CONTINUE 69 : NDI=NVR 70 : IF(NDI.NE.IPC(/1))SEGADJ IDONN 71 : ENDIF 72 : * 73 : * fabrication du listreel 74 : * 75 : JG = NDI 76 : SEGINI MLREEL 77 : DO 7020 I=1,NDI 78 : PROG(I)=XABS(I) 79 : 7020 CONTINUE 80 : MLABS=MLREEL 81 : SEGDES MLREEL 82 : 83 : * on connait la liste XABS (I), IPC(I) quelques verification 84 : * 85 : MCHEL1=IPC(1) 86 : SEGACT MCHEL1 87 : if( mchel1.infche(/2).gt.20) then 88 : write(6,*) 'MANUC8 :probleme de dimension tableau infos ' 88 : call erreur (5) 89 : return 90 : endif 91 : DO 7009 IK=1,MCHEL1.ICHAML(/1) 92 : MCHAML=MCHEL1.ICHAML(IK) 93 : SEGACT MCHAML 94 : IF(IELVAL(/1).NE.1) THEN 94 : CALL ERREUR (21) 95 : ENDIF 96 : 7009 CONTINUE 97 : NOMCH1=NOMCHE(1) 98 : DO 7100 I=2,IPC(/1) 99 : MCHEL2=IPC(I) 100 : SEGACT MCHEL2 101 : if( mchel2.infche(/2).gt.20) then 102 : write(6,*) 'MANUC8 :probleme de dimension tableau infos ' 102 : call erreur (5) 103 : return 104 : endif 105 : IF(MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN 106 : * 107 : * ERREUR IMPOSSIBLE D Avoir DES CHPS/ELMTS 108 : * DE SS TYPE DIFFERENTS 109 : * 110 : MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8) 110 : CALL ERREUR(99) 111 : RETURN 112 : ENDIF 113 : DO 7004 IK=1,MCHEL2.ICHAML(/1) 114 : MCHAML=MCHEL2.ICHAML(IK) 115 : SEGACT MCHAML 116 : IF(IELVAL(/1).NE.1) THEN 116 : CALL ERREUR (21) 117 : ENDIF 118 : IF(NOMCHE(1).NE.NOMCH1) THEN 118 : CALL ERREUR (21) 119 : ENDIF 120 : 7004 CONTINUE 121 : 7100 CONTINUE 122 : MOT=MCHEL1.TITCHE 123 : L1=MCHEL1.TITCHE(/1) 124 : N3=MCHEL1.INFCHE(/2) 125 : NSOUS1=MCHEL1.ICHAML(/1) 126 : * 127 : * QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS SI OUI TRAITEMENT AMELIORE 128 : * 129 : NNCH=IPC(/1) 130 : NNSO=NSOUS1 131 : SEGINI ITAFF 132 : DO 7005 IKK=2,NNCH 133 : MCHEL2=IPC(IKK) 134 : IF( MCHEL2.ICHAML(/1).NE.NSOUS1) THEN 134 : CALL ERREUR(19) 135 : RETURN 136 : ENDIF 137 : 7005 CONTINUE 138 : DO 17 ISOUS1=1,NSOUS1 139 : IPMAI1 = MCHEL1.IMACHE(ISOUS1) 140 : CONCH1 = MCHEL1.CONCHE(ISOUS1) 141 : MCHAML=MCHEL1.ICHAML(ISOUS1) 142 : JTAFF(ISOUS1,1)=IELVAL(1) 143 : DO 7006 IK=2,IPC(/1) 144 : MCHEL2=IPC(IK) 145 : DO 18 ISOUS2=1,NSOUS1 146 : ISOUS=ISOUS2 147 : IPMAI2= MCHEL2.IMACHE(ISOUS) 148 : CONCH2= MCHEL2.CONCHE(ISOUS) 149 : IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN 150 : * 151 : * VERIFICATION POUR LES INFCHE 152 : * 152 : CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) 153 : IF (IRTD.EQ.0) GOTO 18 154 : IMINT1=0 155 : IMINT2=0 156 : IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) 157 : IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) 158 : IF (IMINT1.EQ.IMINT2) GOTO 171 159 : IMINT1=1 160 : IMINT2=1 161 : IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) 162 : IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6) 163 : IF (IMINT1.EQ.0) IMINT1=1 164 : IF (IMINT2.EQ.0) IMINT2=1 165 : IF (IMINT1.EQ.IMINT2) GOTO 171 166 : * 167 : * ERREUR IMPOSSIBLE D Avoir DES CHPS/ELMTS 168 : * DE SS TYPE DIFFERENTS 169 : * 170 : MOTERR(1:8)=MCHEL1.TITCHE 171 : MOTERR(9:16)=MCHEL2.TITCHE 171 : CALL ERREUR(329) 172 : SEGDES MCHEL1,MCHEL2 173 : SEGSUP ITAFF 174 : RETURN 175 : ENDIF 176 : 18 CONTINUE 177 : SEGSUP ITAFF 177 : CALL ERREUR(19) 178 : RETURN 179 : * 180 : 171 CONTINUE 181 : MCHAML= MCHEL2.ICHAML(ISOUS) 182 : JTAFF(ISOUS1,IK)=IELVAL(1) 183 : 7006 CONTINUE 184 : 17 CONTINUE 185 : * 186 : * ON A TROUVE UNE BIJECTION ET ON VECTORISE 187 : * 188 : N1=NSOUS1 189 : N1PTEL=0 190 : N1EL=0 191 : N=1 192 : SEGINI KEVOLL 193 : NUMEVY='REEL' 194 : TYPX='LISTREEL' 195 : TYPY='LISTREEL' 196 : NOMEVX=NCOPO 197 : NOMEVY=NOMCH1 198 : IPROGX=MLABS 199 : NUMEVX=IDCOUL 200 : KEVOL1=KEVOLL 201 : SEGINI MCHELM 202 : TITCHE=MOT 203 : IFOCHE=IFOUR 204 : DO 400 ISOUS=1,NSOUS1 205 : IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) 206 : CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) 207 : DO 401 N33=1,N3 208 : INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33) 209 : 401 CONTINUE 210 : MCHAM1=MCHEL1.ICHAML(ISOUS) 211 : SEGINI,MCHAML=MCHAM1 212 : ICHAML(ISOUS)=MCHAML 213 : TYPCHE='POINTEUREVOLUTIO' 214 : MELVA1=MCHAM1.IELVAL(1) 215 : SEGACT MELVA1 216 : N2PTEL=MELVA1.VELCHE(/1) 217 : N2EL=MELVA1.VELCHE(/2) 218 : SEGINI MELVAL 219 : IELVAL(1)=MELVAL 220 : SEGDES MCHAML 221 : DO 7021 I=1,NNCH 222 : MELVA1=JTAFF(ISOUS,I) 223 : SEGACT MELVA1 224 : 7021 CONTINUE 225 : DO 7010 IAEL=1,N2EL 226 : DO 7010 IAPT=1,N2PTEL 227 : SEGINI MEVOLL 228 : ITYEVO='REEL' 229 : IELCHE(IAPT,IAEL)=MEVOLL 230 : SEGINI,KEVOLL=KEVOL1 231 : SEGINI MLREEL 232 : IPROGY=MLREEL 233 : IEVOLL(1)= KEVOLL 234 : DO 7011 I=1,NNCH 235 : MELVA1=JTAFF(ISOUS,I) 236 : PROG(I)= MELVA1.VELCHE(IAPT,IAEL) 237 : 7011 CONTINUE 238 : SEGDES MLREEL 239 : SEGDES KEVOLL,MEVOLL 240 : 7010 CONTINUE 241 : DO 7022 I=1,NNCH 242 : MELVA1=JTAFF(ISOUS,I) 243 : SEGDES MELVA1 244 : 7022 CONTINUE 245 : SEGDES MELVAL 246 : 400 CONTINUE 247 : SEGDES MCHELM 248 : MRES=MCHELM 249 : * 250 : * desactivation 251 : * 252 : SEGSUP ITAFF 253 : DO 7030 I=1,IPC(/1) 254 : MCHELM=IPC(I) 255 : DO 7031 IK=1,ICHAML(/1) 256 : MCHAML=ICHAML(IK) 257 : SEGDES MCHAML 258 : 7031 CONTINUE 259 : SEGDES MCHELM 260 : 7030 CONTINUE 261 : SEGSUP IDONN 261 : CALL ECROBJ('MCHAML ',MRES) 262 : RETURN 263 : END 264 : 265 : 266 : 267 : 268 : 269 : 270 : 271 : 272 : 273 : 274 : 275 : 276 : 277 : 278 :
© Cast3M 2003 - All rights reserved.
Disclaimer