C MANUC8 SOURCE OF166741 25/02/20 21:16:55 12165 SUBROUTINE MANUC8 IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMCOORD -INC SMCHAML -INC SMLREEL -INC SMEVOLL -INC SMTABLE * attention la dimension de infos doit etre superieure a * deuxieme dimension de infche (= 6) dimension infos(20) SEGMENT IDONN REAL*8 XABS(NDI) INTEGER IPC(NDI) ENDSEGMENT SEGMENT ITAFF INTEGER JTAFF(NNSO,NNCH) ENDSEGMENT CHARACTER*72 MOT CHARACTER*16 CONCH1,CONCH2 CHARACTER*(LOCHAI) NCOPO CHARACTER*(LOCOMP) NOMCH1 * LECTURE DES DONNEES CALL LIRCHA(NCOPO,1,ILO) IF(IERR.NE.0) RETURN * * LECTURE EVENTUELLE D'UNE TABLE et traitement * CALL LIROBJ('TABLE ',MTABLE,0,IRETOU) IF(IRETOU.NE.0) THEN SEGACT MTABLE NDI = MLOTAB SEGINI IDONN NVR=0 DO 7003 I=1,MLOTAB IF(MTABTI(I).NE.'ENTIER '.AND.MTABTI(I).NE.'FLOTTANT') $ GO TO 7003 IF(MTABTV(I).NE.'MCHAML ') GO TO 7003 NVR=NVR+1 IF(MTABTI(I).EQ.'ENTIER ') THEN XABS(NVR)=MTABII(I) ELSE XABS(NVR)= RMTABI(I) ENDIF IPC(NVR)=MTABIV(I) 7003 CONTINUE NDI=NVR IF(NDI.NE.MLOTAB) SEGADJ IDONN ELSE * * LECTURE DES COUPLES ( FLOT MCHAML) * NVR=0 NDI=20 SEGINI IDONN 7001 CONTINUE CALL LIRREE(XVAL,0,IRETOU) IF( IRETOU.EQ.0) GO TO 7002 CALL LIROBJ('MCHAML ',IPCH,1,IRETOU) IF(IERR.NE.0) RETURN NVR=NVR+1 IF(NVR.GT.NDI) THEN NDI = NDI +20 SEGADJ IDONN ENDIF XABS(NVR)=XVAL IPC(NVR)=IPCH GO TO 7001 7002 CONTINUE NDI=NVR IF(NDI.NE.IPC(/1))SEGADJ IDONN ENDIF * * fabrication du listreel * JG = NDI SEGINI MLREEL DO 7020 I=1,NDI PROG(I)=XABS(I) 7020 CONTINUE MLABS=MLREEL SEGDES MLREEL * on connait la liste XABS (I), IPC(I) quelques verification * MCHEL1=IPC(1) SEGACT MCHEL1 if( mchel1.infche(/2).gt.20) then write(6,*) 'MANUC8 :probleme de dimension tableau infos ' call erreur (5) return endif DO 7009 IK=1,MCHEL1.ICHAML(/1) MCHAML=MCHEL1.ICHAML(IK) SEGACT MCHAML IF(IELVAL(/1).NE.1) THEN CALL ERREUR (21) ENDIF 7009 CONTINUE NOMCH1=NOMCHE(1) DO 7100 I=2,IPC(/1) MCHEL2=IPC(I) SEGACT MCHEL2 if(mchel2.infche(/2).gt.20) then write(6,*) 'MANUC8 :probleme de dimension tableau infos ' call erreur (5) return endif IF(MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN * * ERREUR IMPOSSIBLE D Avoir DES CHPS/ELMTS * DE SS TYPE DIFFERENTS * MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8) CALL ERREUR(99) RETURN ENDIF DO 7004 IK=1,MCHEL2.ICHAML(/1) MCHAML=MCHEL2.ICHAML(IK) SEGACT MCHAML IF(IELVAL(/1).NE.1) THEN CALL ERREUR (21) ENDIF IF(NOMCHE(1).NE.NOMCH1) THEN CALL ERREUR (21) ENDIF 7004 CONTINUE 7100 CONTINUE MOT=MCHEL1.TITCHE L1=MCHEL1.TITCHE(/1) N3=MCHEL1.INFCHE(/2) NSOUS1=MCHEL1.ICHAML(/1) * * QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS SI OUI TRAITEMENT AMELIORE * NNCH=IPC(/1) NNSO=NSOUS1 SEGINI ITAFF DO 7005 IKK=2,NNCH MCHEL2=IPC(IKK) IF( MCHEL2.ICHAML(/1).NE.NSOUS1) THEN CALL ERREUR(19) RETURN ENDIF 7005 CONTINUE DO 17 ISOUS1=1,NSOUS1 IPMAI1 = MCHEL1.IMACHE(ISOUS1) CONCH1 = MCHEL1.CONCHE(ISOUS1) MCHAML=MCHEL1.ICHAML(ISOUS1) JTAFF(ISOUS1,1)=IELVAL(1) DO 7006 IK=2,IPC(/1) MCHEL2=IPC(IK) DO 18 ISOUS2=1,NSOUS1 ISOUS=ISOUS2 IPMAI2= MCHEL2.IMACHE(ISOUS) CONCH2= MCHEL2.CONCHE(ISOUS) IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN * * VERIFICATION POUR LES INFCHE * CALL IDENT (IPMAI1,CONCH1,mchel1,mchel2,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 18 IMINT1=MCHEL1.INFCHE(ISOUS1,4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) IF (IMINT1.EQ.IMINT2) GOTO 171 IMINT1= MCHEL1.INFCHE(ISOUS1,6) IMINT2= MCHEL2.INFCHE(ISOUS2,6) IF (IMINT1.EQ.IMINT2) GOTO 171 * * ERREUR IMPOSSIBLE D Avoir DES CHPS/ELMTS * DE SS TYPE DIFFERENTS * MOTERR(1:8)=MCHEL1.TITCHE MOTERR(9:16)=MCHEL2.TITCHE CALL ERREUR(329) SEGDES MCHEL1,MCHEL2 SEGSUP ITAFF RETURN ENDIF 18 CONTINUE SEGSUP ITAFF CALL ERREUR(19) RETURN * 171 CONTINUE MCHAML= MCHEL2.ICHAML(ISOUS) JTAFF(ISOUS1,IK)=IELVAL(1) 7006 CONTINUE 17 CONTINUE * * ON A TROUVE UNE BIJECTION ET ON VECTORISE * N1=NSOUS1 N1PTEL=0 N1EL=0 N=1 SEGINI KEVOLL NUMEVY='REEL' TYPX='LISTREEL' TYPY='LISTREEL' NOMEVX=NCOPO NOMEVY=NOMCH1 IPROGX=MLABS NUMEVX=IDCOUL KEVOL1=KEVOLL SEGINI MCHELM TITCHE=MOT IFOCHE=IFOUR DO 400 ISOUS=1,NSOUS1 IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) DO 401 N33=1,N3 INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33) 401 CONTINUE MCHAM1=MCHEL1.ICHAML(ISOUS) SEGINI,MCHAML=MCHAM1 ICHAML(ISOUS)=MCHAML TYPCHE='POINTEUREVOLUTIO' MELVA1=MCHAM1.IELVAL(1) SEGACT MELVA1 N2PTEL=MELVA1.VELCHE(/1) N2EL=MELVA1.VELCHE(/2) SEGINI MELVAL IELVAL(1)=MELVAL SEGDES MCHAML DO 7021 I=1,NNCH MELVA1=JTAFF(ISOUS,I) SEGACT MELVA1 7021 CONTINUE DO 7010 IAEL=1,N2EL DO 7010 IAPT=1,N2PTEL SEGINI MEVOLL ITYEVO='REEL' IELCHE(IAPT,IAEL)=MEVOLL SEGINI,KEVOLL=KEVOL1 SEGINI MLREEL IPROGY=MLREEL IEVOLL(1)= KEVOLL DO 7011 I=1,NNCH MELVA1=JTAFF(ISOUS,I) PROG(I)= MELVA1.VELCHE(IAPT,IAEL) 7011 CONTINUE SEGDES MLREEL SEGDES KEVOLL,MEVOLL 7010 CONTINUE DO 7022 I=1,NNCH MELVA1=JTAFF(ISOUS,I) SEGDES MELVA1 7022 CONTINUE SEGDES MELVAL 400 CONTINUE SEGDES MCHELM MRES=MCHELM * * desactivation * SEGSUP ITAFF DO 7030 I=1,IPC(/1) MCHELM=IPC(I) DO 7031 IK=1,ICHAML(/1) MCHAML=ICHAML(IK) SEGDES MCHAML 7031 CONTINUE SEGDES MCHELM 7030 CONTINUE SEGSUP IDONN CALL ECROBJ('MCHAML ',MRES) RETURN END