1 : C PROLI2 SOURCE CHAT 05/01/13 02:32:40 5004 2 : SUBROUTINE PROLI2(LMDUAB,LMPRIB,LMPRIC,LMDUAC, 3 : $ LILBLC,KRMPRI,KMDCDB,KMPRBP, 4 : $ SLCHPD,SLMATB,SLMATC, 5 : $ LMPCDB,LMDCDB,NELCDB, 6 : $ SLMCDB, 7 : $ IMPR,IRET) 8 : IMPLICIT INTEGER(I-N) 9 : IMPLICIT REAL*8 (A-H,O-Z) 10 : C*********************************************************************** 11 : C NOM : PROLI2 12 : C DESCRIPTION : Produit des matrices stockées sous forme de listes 13 : C indexées (2 : Boucles sur les éléments) 14 : C 15 : C 16 : C 17 : C LANGAGE : ESOPE 18 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 19 : C mél : gounand@semt2.smts.cea.fr 20 : C*********************************************************************** 21 : C APPELES : - 22 : C APPELE PAR : PROLIS 23 : C*********************************************************************** 24 : C ENTREES : tout sauf SLMCDB 25 : C SORTIES : SLMCDB 26 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 27 : C*********************************************************************** 28 : C VERSION : v1, 14/02/2000, version initiale 29 : C HISTORIQUE : v1, 14/02/2000, création 30 : C HISTORIQUE : 31 : C HISTORIQUE : 32 : C*********************************************************************** 33 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 34 : C en cas de modification de ce sous-programme afin de faciliter 35 : C la maintenance ! 36 : C*********************************************************************** 37 : -INC CCOPTIO 38 : -INC SMLENTI 39 : POINTEUR KRMPRI.MLENTI 40 : POINTEUR KMPRBP.MLENTI 41 : POINTEUR KMDCDB.MLENTI 42 : * Includes persos 43 : * Segment LSTIND (liste séquentielle indexée) 44 : SEGMENT LSTIND 45 : INTEGER IDX(NBM+1) 46 : INTEGER IVAL(NBTVAL) 47 : ENDSEGMENT 48 : POINTEUR LMDUAB.LSTIND 49 : POINTEUR LMPRIB.LSTIND 50 : POINTEUR LMPRIC.LSTIND 51 : POINTEUR LMDUAC.LSTIND 52 : POINTEUR LILBLC.LSTIND 53 : POINTEUR LMPCDB.LSTIND 54 : POINTEUR LMDCDB.LSTIND 55 : SEGMENT LSRIND 56 : INTEGER IDXX(NBM+1) 57 : REAL*8 XVAL(NBTVAL) 58 : ENDSEGMENT 59 : POINTEUR SLMATB.LSRIND 60 : POINTEUR SLMATC.LSRIND 61 : POINTEUR SLMCDB.LSRIND 62 : -INC SMLREEL 63 : POINTEUR SLCHPD.MLREEL 64 : * 65 : INTEGER NELCDB 66 : INTEGER IMPR,IRET 67 : * 68 : INTEGER IELCDB 69 : INTEGER KVDCDB,KVSTRT,KVSTOP,IPDCDB 70 : INTEGER LVMPBP,LVSTRT,LVSTOP 71 : INTEGER MVLBLC,MVSTRT,MVSTOP 72 : INTEGER NVPRIC,NVSTRT,NVSTOP 73 : INTEGER OVDUAC,OVSTRT,OVSTOP 74 : INTEGER PVDUAB,PVSTRT,PVSTOP 75 : INTEGER QVMATC,QVSTRT 76 : INTEGER RVMATB,RVSTRT 77 : INTEGER SVMCDB,SVSTRT 78 : INTEGER NPPB,NPPC,NPPCDB 79 : INTEGER NLOCPB,NUELC,NUMPC,NUPBP,NUPDP 80 : REAL*8 BIJ,CIK,COEFD 81 : * 82 : * Executable statements 83 : * 84 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans proli2.eso' 85 : * 86 : * Boucle sur les éléments de CD-1Bt 87 : * 88 : *COMM SEGPRT,LMDCDB 89 : DO 1 IELCDB=1,NELCDB 90 : * On construit KRDCDB 91 : KVSTRT=LMDCDB.IDX(IELCDB) 92 : KVSTOP=LMDCDB.IDX(IELCDB+1)-1 93 : DO 11 KVDCDB=KVSTRT,KVSTOP 94 : NUPDP=LMDCDB.IVAL(KVDCDB) 95 : KMDCDB.LECT(NUPDP)=KVDCDB-KVSTRT 96 : 11 CONTINUE 97 : *COMM WRITE(IOIMP,*) 'Repérage dans LMDCDB' 98 : *COMM SEGPRT,KMDCDB 99 : * On construit KRMPBP 100 : LVSTRT=LMPRIB.IDX(IELCDB) 101 : LVSTOP=LMPRIB.IDX(IELCDB+1)-1 102 : DO 12 LVMPBP=LVSTRT,LVSTOP 103 : NUPBP=LMPRIB.IVAL(LVMPBP) 104 : IF (KRMPRI.LECT(NUPBP).NE.0) THEN 105 : KMPRBP.LECT(NUPBP)=LVMPBP-LVSTRT+1 106 : ENDIF 107 : 12 CONTINUE 108 : *COMM WRITE(IOIMP,*) 'Repérage dans LMPRIB' 109 : *COMM SEGPRT,KMPRBP 110 : *COMM WRITE(IOIMP,*) 'Numéro d''élément de CD-1Bt (ouB)=',IELCDB 111 : NPPCDB=LMPCDB.IDX(IELCDB+1)-LMPCDB.IDX(IELCDB) 112 : NPPB =LMPRIB.IDX(IELCDB+1)-LMPRIB.IDX(IELCDB) 113 : RVSTRT=SLMATB.IDXX(IELCDB) 114 : SVSTRT=SLMCDB.IDXX(IELCDB) 115 : * On parcourt les éléments de la matrice C de ayant au moins un point 116 : * commmun avec un élément de la matrice B courante 117 : MVSTRT=LILBLC.IDX(IELCDB) 118 : MVSTOP=LILBLC.IDX(IELCDB+1)-1 119 : DO 13 MVLBLC=MVSTRT,MVSTOP 120 : NUELC=LILBLC.IVAL(MVLBLC) 121 : *COMM WRITE(IOIMP,*) ' Numéro d''élément C',NUELC 122 : NPPC=LMPRIC.IDX(NUELC+1)-LMPRIC.IDX(NUELC) 123 : QVSTRT=SLMATC.IDXX(NUELC) 124 : * Parcourons les points de l'élément NUELC de MPRIC 125 : NVSTRT=LMPRIC.IDX(NUELC) 126 : NVSTOP=LMPRIC.IDX(NUELC+1)-1 127 : DO 132 NVPRIC=NVSTRT,NVSTOP 128 : NUMPC=LMPRIC.IVAL(NVPRIC) 129 : *COMM WRITE(IOIMP,*) ' Point du primal de C :',NUMPC 130 : NLOCPB=KMPRBP.LECT(NUMPC) 131 : *COMM WRITE(IOIMP,*) ' NLOCPB=',NLOCPB 132 : IF (NLOCPB.NE.0) THEN 133 : * On a trouvé un point de MPRIB qui correspond donc 134 : * on parcourt les points de l'élément NUELC de MDUAC 135 : * et les points de l'élément IELCDB de MDUAB 136 : OVSTRT=LMDUAC.IDX(NUELC) 137 : OVSTOP=LMDUAC.IDX(NUELC+1)-1 138 : PVSTRT=LMDUAB.IDX(IELCDB) 139 : PVSTOP=LMDUAB.IDX(IELCDB+1)-1 140 : IF (SLCHPD.NE.0) THEN 141 : COEFD=SLCHPD.PROG(KRMPRI.LECT(NUMPC)) 142 : *COMM WRITE(IOIMP,*) ' COEFD=',COEFD 143 : ENDIF 144 : DO 1322 OVDUAC=OVSTRT,OVSTOP 145 : *COMM write(ioimp,*) ' po. dua. C=', 146 : *COMM $ LMDUAC.IVAL(OVDUAC) 147 : QVMATC=QVSTRT+ 148 : $ (NPPC*(OVDUAC-OVSTRT)+(NVPRIC-NVSTRT)) 149 : CIK=SLMATC.XVAL(QVMATC) 150 : *COMM WRITE(IOIMP,*) ' CIK=',CIK 151 : IPDCDB=KMDCDB.LECT(LMDUAC.IVAL(OVDUAC)) 152 : DO 13222 PVDUAB=PVSTRT,PVSTOP 153 : *COMM write(ioimp,*) ' po. dua. B=', 154 : *COMM $ LMDUAB.IVAL(PVDUAB) 155 : RVMATB=RVSTRT+ 156 : $ (NPPB*(PVDUAB-PVSTRT)+(NLOCPB-1)) 157 : BIJ=SLMATB.XVAL(RVMATB) 158 : *COMM WRITE(IOIMP,*) ' BIJ=',BIJ 159 : SVMCDB=SVSTRT+ 160 : $ (IPDCDB*NPPCDB+(PVDUAB-PVSTRT)) 161 : *COMM WRITE(IOIMP,*) ' SVMCDB=',SVMCDB 162 : IF (SLCHPD.NE.0) THEN 163 : SLMCDB.XVAL(SVMCDB)=SLMCDB.XVAL(SVMCDB) 164 : $ +(BIJ*COEFD*CIK) 165 : ELSE 166 : SLMCDB.XVAL(SVMCDB)=SLMCDB.XVAL(SVMCDB) 167 : $ +(BIJ*CIK) 168 : ENDIF 169 : 13222 CONTINUE 170 : 1322 CONTINUE 171 : ENDIF 172 : 132 CONTINUE 173 : 13 CONTINUE 174 : * On remet KRMPBP à 0 175 : DO 15 LVMPBP=LVSTRT,LVSTOP 176 : NUPBP=LMPRIB.IVAL(LVMPBP) 177 : IF (KRMPRI.LECT(NUPBP).NE.0) THEN 178 : KMPRBP.LECT(NUPBP)=0 179 : ENDIF 180 : 15 CONTINUE 181 : * On remet KRDCDB à 0 182 : DO 17 KVDCDB=KVSTRT,KVSTOP 183 : NUPDP=LMDCDB.IVAL(IELCDB) 184 : KMDCDB.LECT(NUPDP)=0 185 : 17 CONTINUE 186 : 1 CONTINUE 187 : 188 : * 189 : * Normal termination 190 : * 191 : IRET=0 192 : RETURN 193 : * 194 : * Format handling 195 : * 196 : * 197 : * Error handling 198 : * 199 : 9999 CONTINUE 200 : IRET=1 201 : WRITE(IOIMP,*) 'An error was detected in subroutine proli2' 202 : RETURN 203 : * 204 : * End of subroutine PROLI2 205 : * 206 : END 207 : 208 : 209 : 210 :
© Cast3M 2003 - All rights reserved.
Disclaimer