C PROLI2 SOURCE CHAT 05/01/13 02:32:40 5004 SUBROUTINE PROLI2(LMDUAB,LMPRIB,LMPRIC,LMDUAC, $ LILBLC,KRMPRI,KMDCDB,KMPRBP, $ SLCHPD,SLMATB,SLMATC, $ LMPCDB,LMDCDB,NELCDB, $ SLMCDB, $ IMPR,IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C*********************************************************************** C NOM : PROLI2 C DESCRIPTION : Produit des matrices stockées sous forme de listes C indexées (2 : Boucles sur les éléments) C C C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES : - C APPELE PAR : PROLIS C*********************************************************************** C ENTREES : tout sauf SLMCDB C SORTIES : SLMCDB C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 14/02/2000, version initiale C HISTORIQUE : v1, 14/02/2000, création C HISTORIQUE : C HISTORIQUE : C*********************************************************************** C Prière de PRENDRE LE TEMPS de compléter les commentaires C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** -INC PPARAM -INC CCOPTIO -INC SMLENTI POINTEUR KRMPRI.MLENTI POINTEUR KMPRBP.MLENTI POINTEUR KMDCDB.MLENTI * Includes persos * Segment LSTIND (liste séquentielle indexée) SEGMENT LSTIND INTEGER IDX(NBM+1) INTEGER IVAL(NBTVAL) ENDSEGMENT POINTEUR LMDUAB.LSTIND POINTEUR LMPRIB.LSTIND POINTEUR LMPRIC.LSTIND POINTEUR LMDUAC.LSTIND POINTEUR LILBLC.LSTIND POINTEUR LMPCDB.LSTIND POINTEUR LMDCDB.LSTIND SEGMENT LSRIND INTEGER IDXX(NBM+1) REAL*8 XVAL(NBTVAL) ENDSEGMENT POINTEUR SLMATB.LSRIND POINTEUR SLMATC.LSRIND POINTEUR SLMCDB.LSRIND -INC SMLREEL POINTEUR SLCHPD.MLREEL * INTEGER NELCDB INTEGER IMPR,IRET * INTEGER IELCDB INTEGER KVDCDB,KVSTRT,KVSTOP,IPDCDB INTEGER LVMPBP,LVSTRT,LVSTOP INTEGER MVLBLC,MVSTRT,MVSTOP INTEGER NVPRIC,NVSTRT,NVSTOP INTEGER OVDUAC,OVSTRT,OVSTOP INTEGER PVDUAB,PVSTRT,PVSTOP INTEGER QVMATC,QVSTRT INTEGER RVMATB,RVSTRT INTEGER SVMCDB,SVSTRT INTEGER NPPB,NPPC,NPPCDB INTEGER NLOCPB,NUELC,NUMPC,NUPBP,NUPDP REAL*8 BIJ,CIK,COEFD * * Executable statements * IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans proli2.eso' * * Boucle sur les éléments de CD-1Bt * *COMM SEGPRT,LMDCDB DO 1 IELCDB=1,NELCDB * On construit KRDCDB KVSTRT=LMDCDB.IDX(IELCDB) KVSTOP=LMDCDB.IDX(IELCDB+1)-1 DO 11 KVDCDB=KVSTRT,KVSTOP NUPDP=LMDCDB.IVAL(KVDCDB) KMDCDB.LECT(NUPDP)=KVDCDB-KVSTRT 11 CONTINUE *COMM WRITE(IOIMP,*) 'Repérage dans LMDCDB' *COMM SEGPRT,KMDCDB * On construit KRMPBP LVSTRT=LMPRIB.IDX(IELCDB) LVSTOP=LMPRIB.IDX(IELCDB+1)-1 DO 12 LVMPBP=LVSTRT,LVSTOP NUPBP=LMPRIB.IVAL(LVMPBP) IF (KRMPRI.LECT(NUPBP).NE.0) THEN KMPRBP.LECT(NUPBP)=LVMPBP-LVSTRT+1 ENDIF 12 CONTINUE *COMM WRITE(IOIMP,*) 'Repérage dans LMPRIB' *COMM SEGPRT,KMPRBP *COMM WRITE(IOIMP,*) 'Numéro d''élément de CD-1Bt (ouB)=',IELCDB NPPCDB=LMPCDB.IDX(IELCDB+1)-LMPCDB.IDX(IELCDB) NPPB =LMPRIB.IDX(IELCDB+1)-LMPRIB.IDX(IELCDB) RVSTRT=SLMATB.IDXX(IELCDB) SVSTRT=SLMCDB.IDXX(IELCDB) * On parcourt les éléments de la matrice C de ayant au moins un point * commmun avec un élément de la matrice B courante MVSTRT=LILBLC.IDX(IELCDB) MVSTOP=LILBLC.IDX(IELCDB+1)-1 DO 13 MVLBLC=MVSTRT,MVSTOP NUELC=LILBLC.IVAL(MVLBLC) *COMM WRITE(IOIMP,*) ' Numéro d''élément C',NUELC NPPC=LMPRIC.IDX(NUELC+1)-LMPRIC.IDX(NUELC) QVSTRT=SLMATC.IDXX(NUELC) * Parcourons les points de l'élément NUELC de MPRIC NVSTRT=LMPRIC.IDX(NUELC) NVSTOP=LMPRIC.IDX(NUELC+1)-1 DO 132 NVPRIC=NVSTRT,NVSTOP NUMPC=LMPRIC.IVAL(NVPRIC) *COMM WRITE(IOIMP,*) ' Point du primal de C :',NUMPC NLOCPB=KMPRBP.LECT(NUMPC) *COMM WRITE(IOIMP,*) ' NLOCPB=',NLOCPB IF (NLOCPB.NE.0) THEN * On a trouvé un point de MPRIB qui correspond donc * on parcourt les points de l'élément NUELC de MDUAC * et les points de l'élément IELCDB de MDUAB OVSTRT=LMDUAC.IDX(NUELC) OVSTOP=LMDUAC.IDX(NUELC+1)-1 PVSTRT=LMDUAB.IDX(IELCDB) PVSTOP=LMDUAB.IDX(IELCDB+1)-1 IF (SLCHPD.NE.0) THEN COEFD=SLCHPD.PROG(KRMPRI.LECT(NUMPC)) *COMM WRITE(IOIMP,*) ' COEFD=',COEFD ENDIF DO 1322 OVDUAC=OVSTRT,OVSTOP *COMM write(ioimp,*) ' po. dua. C=', *COMM $ LMDUAC.IVAL(OVDUAC) QVMATC=QVSTRT+ $ (NPPC*(OVDUAC-OVSTRT)+(NVPRIC-NVSTRT)) CIK=SLMATC.XVAL(QVMATC) *COMM WRITE(IOIMP,*) ' CIK=',CIK IPDCDB=KMDCDB.LECT(LMDUAC.IVAL(OVDUAC)) DO 13222 PVDUAB=PVSTRT,PVSTOP *COMM write(ioimp,*) ' po. dua. B=', *COMM $ LMDUAB.IVAL(PVDUAB) RVMATB=RVSTRT+ $ (NPPB*(PVDUAB-PVSTRT)+(NLOCPB-1)) BIJ=SLMATB.XVAL(RVMATB) *COMM WRITE(IOIMP,*) ' BIJ=',BIJ SVMCDB=SVSTRT+ $ (IPDCDB*NPPCDB+(PVDUAB-PVSTRT)) *COMM WRITE(IOIMP,*) ' SVMCDB=',SVMCDB IF (SLCHPD.NE.0) THEN SLMCDB.XVAL(SVMCDB)=SLMCDB.XVAL(SVMCDB) $ +(BIJ*COEFD*CIK) ELSE SLMCDB.XVAL(SVMCDB)=SLMCDB.XVAL(SVMCDB) $ +(BIJ*CIK) ENDIF 13222 CONTINUE 1322 CONTINUE ENDIF 132 CONTINUE 13 CONTINUE * On remet KRMPBP à 0 DO 15 LVMPBP=LVSTRT,LVSTOP NUPBP=LMPRIB.IVAL(LVMPBP) IF (KRMPRI.LECT(NUPBP).NE.0) THEN KMPRBP.LECT(NUPBP)=0 ENDIF 15 CONTINUE * On remet KRDCDB à 0 DO 17 KVDCDB=KVSTRT,KVSTOP NUPDP=LMDCDB.IVAL(IELCDB) KMDCDB.LECT(NUPDP)=0 17 CONTINUE 1 CONTINUE * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine proli2' RETURN * * End of subroutine PROLI2 * END