1 : C LIMTIK SOURCE MAGN 09/07/30 21:19:06 6458 2 : SUBROUTINE LIMTIK(IFRES,ITLACC,IMAX1,IRET,IFORM) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C*********************************************************************** 6 : C NOM : LIMTAK 7 : C DESCRIPTION : Lecture d'un objet de type MATRIK sur le 8 : C fichier IFRES 9 : C (appelé par lipil.eso) 10 : C 11 : C LANGAGE : ESOPE 12 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF) 13 : C mél : gounand@semt2.smts.cea.fr 14 : C*********************************************************************** 15 : C APPELES (E/S) : LFCDIE (lecture d'un tableau d'entiers) 16 : C LFCDI2 (lecture d'un tableau de REAL*8) 17 : C LFCDIM (lecture d'un tableau de CHARACTER*4) 18 : C*********************************************************************** 19 : C SYNTAXE GIBIANE : RESTITUER 20 : C ENTREES : IFRES, numéro du fichier de lecture 21 : C IMAX1, nombre d'objets MATRIK à lire 22 : C IFORM, le fichier à lire est formaté ou 23 : C non. 24 : C ENTREES/SORTIES : ITLACC, la pile des objets MATRIK à 25 : C laquelle on ajoute les objets lus 26 : C CODE RETOUR (IRET) : 0, ok 27 : C 1, erreur dans la lecture de l'objet 28 : C*********************************************************************** 29 : C VERSION : v1, 15/07/98, version initiale 30 : C HISTORIQUE : v1, 15/07/98, création 31 : C HISTORIQUE : 32 : C HISTORIQUE : 33 : C*********************************************************************** 34 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 35 : C en cas de modification de ce sous-programme afin de faciliter 36 : C la maintenance ! 37 : C*********************************************************************** 38 : -INC CCOPTIO 39 : -INC SMMATRIK 40 : -INC TMCOLAC 41 : SEGMENT/ITBBM1/( ITABM1(NM)) 42 : C 43 : INTEGER NDTAB 44 : INTEGER IEL,I,J,K,L 45 : INTEGER ILENA(11) 46 : C====================================================================== 47 : * 48 : * Executable statements 49 : * 50 : IRET=0 51 : IRETOU=0 52 : NM=0 53 : SEGINI ITBBM1 54 : DO 1 IEL=1,IMAX1 55 : C Restitution du chapeau 56 : C.... On initialise des piles d'objets non connus de CASTEM 57 : C MINC, PMORS, IZA, IDMAT 58 : SEGINI ITLAC1 59 : SEGINI ITLAC2 60 : SEGINI ITLAC3 61 : SEGINI ITLAC4 62 : MATRIK=0 63 : C Dimensions 64 : NDTAB=4 64 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 65 : IF (IRETOU.NE.0) GOTO 9999 66 : NRIGE =ILENA(1) 67 : NMATRI=ILENA(2) 68 : NKID =ILENA(3) 69 : NKMT =ILENA(4) 70 : SEGINI MATRIK 71 : C Rigidités élémentaires 72 : NDTAB = NRIGE * NMATRI 72 : CALL LFCDIE(IFRES,NDTAB,IRIGEL,IRETOU,IFORM) 73 : IF (IRETOU.NE.0) GOTO 9999 74 : C Matrice assemblée 75 : NDTAB=11 75 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 76 : IF (IRETOU.NE.0) GOTO 9999 77 : KSYM =ILENA( 1) 78 : KMINC =ILENA( 2) 79 : KMINCP=ILENA( 3) 80 : KMINCD=ILENA( 4) 81 : KIZM =ILENA( 5) 82 : KISPGT=ILENA( 6) 83 : KISPGP=ILENA( 7) 84 : KISPGD=ILENA( 8) 85 : KNTTT =ILENA( 9) 86 : KNTTP =ILENA(10) 87 : KNTTD =ILENA(11) 88 : NDTAB=NKID 88 : CALL LFCDIE(IFRES,NDTAB,KIDMAT,IRETOU,IFORM) 89 : IF (IRETOU.NE.0) GOTO 9999 90 : NDTAB=NKMT 90 : CALL LFCDIE(IFRES,NDTAB,KKMMT,IRETOU,IFORM) 91 : IF (IRETOU.NE.0) GOTO 9999 92 : C Restitution des IMATRI 93 : DO 11 I=1,NMATRI 94 : IMATRI=IRIGEL(4,I) 95 : IF (IMATRI.NE.0) THEN 96 : NDTAB=2 96 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 97 : IF (IRETOU.NE.0) GOTO 9999 98 : NBSOUS=ILENA(1) 99 : NBME =ILENA(2) 100 : SEGINI IMATRI 101 : NM=4*NBME 102 : SEGADJ ITBBM1 102 : CALL LFCDIM(IFRES,NM,ITABM1,IRETOU,IFORM) 103 : DO 111 J=1,NBME 104 : J4=(4*J)-3 105 : WRITE(LISPRI(J),FMT='(2A4)') ITABM1(J4),ITABM1(J4+1) 106 : WRITE(LISDUA(J),FMT='(2A4)') ITABM1(J4+2),ITABM1(J4+3) 107 : 111 CONTINUE 108 : NDTAB=NBSOUS*NBME 108 : CALL LFCDIE(IFRES,NDTAB,LIZAFM,IRETOU,IFORM) 109 : IF (IRETOU.NE.0) GOTO 9999 110 : NDTAB=2 110 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 111 : IF (IRETOU.NE.0) GOTO 9999 112 : KSPGP=ILENA(1) 113 : KSPGD=ILENA(2) 114 : C Restitution des IZAFM 115 : DO 112 K=1,NBME 116 : DO 1121 L=1,NBSOUS 117 : IZAFM=LIZAFM(L,K) 118 : IF (IZAFM.NE.0) THEN 119 : NDTAB=3 119 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 120 : IF (IRETOU.NE.0) GOTO 9999 121 : NBEL=ILENA(1) 122 : NP =ILENA(2) 123 : MP =ILENA(3) 124 : SEGINI IZAFM 125 : NDTAB=NBEL*NP*MP 125 : CALL LFCDI2(IFRES,NDTAB,AM,IRETOU,IFORM) 126 : IF (IRETOU.NE.0) GOTO 9999 127 : SEGDES IZAFM 128 : LIZAFM(L,K)=IZAFM 129 : ENDIF 130 : 1121 CONTINUE 131 : 112 CONTINUE 132 : SEGDES IMATRI 133 : IRIGEL(4,I)=IMATRI 134 : ENDIF 135 : 11 CONTINUE 136 : C Restitution des MINC 137 : NDTAB=4 137 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 138 : IF (IRETOU.NE.0) GOTO 9999 139 : NBMINC=ILENA(1) 140 : JMINC =ILENA(2) 141 : JMINCP=ILENA(3) 142 : JMINCD=ILENA(4) 143 : DO 12 I=1,NBMINC 144 : NDTAB=2 144 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 145 : IF (IRETOU.NE.0) GOTO 9999 146 : NPT=ILENA(1) 147 : NBI=ILENA(2) 148 : SEGINI MINC 149 : NM=2*NBI 150 : SEGADJ ITBBM1 150 : CALL LFCDIM(IFRES,NM,ITABM1,IRETOU,IFORM) 151 : IF (IRETOU.NE.0) GOTO 9999 152 : DO 121 J=1,NBI 153 : J2=(2*J)-1 154 : WRITE(LISINC(J),FMT='(2A4)') ITABM1(J2),ITABM1(J2+1) 155 : 121 CONTINUE 156 : NDTAB=NPT+1 156 : CALL LFCDIE(IFRES,NDTAB,NPOS,IRETOU,IFORM) 157 : IF (IRETOU.NE.0) GOTO 9999 158 : NDTAB=NPT*(NBI+1) 158 : CALL LFCDIE(IFRES,NDTAB,MPOS,IRETOU,IFORM) 159 : IF (IRETOU.NE.0) GOTO 9999 160 : SEGDES MINC 161 : ITLAC1.ITLAC(**)=MINC 162 : 12 CONTINUE 163 : IF (JMINC.NE.0) KMINC =ITLAC1.ITLAC(JMINC) 164 : IF (JMINCP.NE.0) KMINCP=ITLAC1.ITLAC(JMINCP) 165 : IF (JMINCD.NE.0) KMINCD=ITLAC1.ITLAC(JMINCD) 166 : C Restitution des PMORS 167 : NDTAB=3 167 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 168 : IF (IRETOU.NE.0) GOTO 9999 169 : NBMORS=ILENA(1) 170 : JMORS =ILENA(2) 171 : JMRST =ILENA(3) 172 : DO 13 I=1,NBMORS 173 : NDTAB=2 173 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 174 : IF (IRETOU.NE.0) GOTO 9999 175 : NTT=ILENA(1) 176 : NJA=ILENA(2) 177 : SEGINI PMORS 178 : NDTAB=NTT+1 178 : CALL LFCDIE(IFRES,NDTAB,IA,IRETOU,IFORM) 179 : IF (IRETOU.NE.0) GOTO 9999 180 : NDTAB=NJA 180 : CALL LFCDIE(IFRES,NDTAB,JA,IRETOU,IFORM) 181 : IF (IRETOU.NE.0) GOTO 9999 182 : SEGDES PMORS 183 : ITLAC2.ITLAC(**)=PMORS 184 : 13 CONTINUE 185 : IF (JMORS.NE.0) KIDMAT(4)=ITLAC2.ITLAC(JMORS) 186 : IF (JMRST.NE.0) KIDMAT(6)=ITLAC2.ITLAC(JMRST) 187 : C Restitution des IDMAT (faite avant les IZA 188 : C car IDIAG pointe sur un IZA) 189 : NDTAB=3 189 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 190 : IF (IRETOU.NE.0) GOTO 9999 191 : NBIDMA=ILENA(1) 192 : JDMATP=ILENA(2) 193 : JDMATD=ILENA(3) 194 : DO 15 I=1,NBIDMA 195 : NDTAB=4 195 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 196 : IF (IRETOU.NE.0) GOTO 9999 197 : NTT =ILENA(1) 198 : NPT =ILENA(2) 199 : NBLK=ILENA(3) 200 : SEGINI IDMAT 201 : IDIAG=ILENA(4) 202 : NDTAB=NTT 202 : CALL LFCDIE(IFRES,NDTAB,KZA,IRETOU,IFORM) 203 : IF (IRETOU.NE.0) GOTO 9999 204 : NDTAB=2*NTT 204 : CALL LFCDIE(IFRES,NDTAB,NUIA,IRETOU,IFORM) 205 : IF (IRETOU.NE.0) GOTO 9999 206 : NDTAB=NPT 206 : CALL LFCDIE(IFRES,NDTAB,NUAN,IRETOU,IFORM) 207 : IF (IRETOU.NE.0) GOTO 9999 208 : NDTAB=NPT 208 : CALL LFCDIE(IFRES,NDTAB,NUNA,IRETOU,IFORM) 209 : IF (IRETOU.NE.0) GOTO 9999 210 : NDTAB=NBLK 210 : CALL LFCDIE(IFRES,NDTAB,IDESCL,IRETOU,IFORM) 211 : IF (IRETOU.NE.0) GOTO 9999 212 : NDTAB=NBLK 212 : CALL LFCDIE(IFRES,NDTAB,IDESCU,IRETOU,IFORM) 213 : IF (IRETOU.NE.0) GOTO 9999 214 : NDTAB=NBLK+1 214 : CALL LFCDIE(IFRES,NDTAB,NLDBLK,IRETOU,IFORM) 215 : IF (IRETOU.NE.0) GOTO 9999 216 : SEGDES IDMAT 217 : ITLAC4.ITLAC(**)=IDMAT 218 : 15 CONTINUE 219 : IF (JDMATP.NE.0) KIDMAT(1)=ITLAC4.ITLAC(JDMATP) 220 : IF (JDMATD.NE.0) KIDMAT(2)=ITLAC4.ITLAC(JDMATD) 221 : C Restitution des IZA 222 : NDTAB=8 222 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 223 : IF (IRETOU.NE.0) GOTO 9999 224 : NBIZA =ILENA( 1) 225 : JS2B =ILENA( 2) 226 : JISA =ILENA( 3) 227 : JIST =ILENA( 4) 228 : JZDU =ILENA( 5) 229 : JZDP =ILENA( 6) 230 : JZFU =ILENA( 7) 231 : JZFP =ILENA( 8) 232 : DO 14 I=1,NBIZA 233 : NDTAB=1 233 : CALL LFCDIE(IFRES,NDTAB,ILENA,IRETOU,IFORM) 234 : IF (IRETOU.NE.0) GOTO 9999 235 : NBVA=ILENA(1) 236 : SEGINI IZA 237 : NDTAB=NBVA 237 : CALL LFCDI2(IFRES,NDTAB,A,IRETOU,IFORM) 238 : IF (IRETOU.NE.0) GOTO 9999 239 : SEGDES IZA 240 : ITLAC3.ITLAC(**)=IZA 241 : 14 CONTINUE 242 : IF (JS2B.NE.0) KIDMAT(3)=ITLAC3.ITLAC(JS2B) 243 : IF (JISA.NE.0) KIDMAT(5)=ITLAC3.ITLAC(JISA) 244 : IF (JIST.NE.0) KIDMAT(7)=ITLAC3.ITLAC(JIST) 245 : IF (JZDU.NE.0) KKMMT (4)=ITLAC3.ITLAC(JZDU) 246 : IF (JZDP.NE.0) KKMMT (5)=ITLAC3.ITLAC(JZDP) 247 : IF (JZFU.NE.0) KKMMT (6)=ITLAC3.ITLAC(JZFU) 248 : IF (JZFP.NE.0) KKMMT (7)=ITLAC3.ITLAC(JZFP) 249 : C Restauration des pointeurs des IZA dans IDMAT 250 : DO 17 I=1,NBIDMA 251 : IDMAT=ITLAC4.ITLAC(I) 252 : SEGACT IDMAT*MOD 253 : NBLK=IDESCL(/1) 254 : C IDIAG 255 : IV3=IDIAG 256 : IF (IV3.NE.0) IDIAG=ITLAC3.ITLAC(IV3) 257 : C IDESCL 258 : DO 171 J=1,NBLK 259 : IV3=IDESCL(J) 260 : IF (IV3.NE.0) IDESCL(J)=ITLAC3.ITLAC(IV3) 261 : 171 CONTINUE 262 : C IDESCU 263 : DO 172 J=1,NBLK 264 : IV3=IDESCU(J) 265 : IF (IV3.NE.0) IDESCU(J)=ITLAC3.ITLAC(IV3) 266 : 172 CONTINUE 267 : SEGDES IDMAT 268 : 17 CONTINUE 269 : SEGDES MATRIK 270 : ITLAC(**)=MATRIK 271 : SEGSUP ITLAC4 272 : SEGSUP ITLAC3 273 : SEGSUP ITLAC2 274 : SEGSUP ITLAC1 275 : 1 CONTINUE 276 : SEGSUP ITBBM1 277 : * 278 : * Normal termination 279 : * 280 : IRET=0 281 : RETURN 282 : * 283 : * Format handling 284 : * 285 : * 286 : * Error handling 287 : * 288 : 9999 CONTINUE 289 : WRITE(IOIMP,*) 'An error was detected in subroutine limtik' 290 : IRET=1 291 : RETURN 292 : * 293 : * End of subroutine LIMTIK 294 : * 295 : END 296 : 297 : 298 : 299 : 300 : 301 : 302 : 303 : 304 : 305 :
© Cast3M 2003 - All rights reserved.
Disclaimer