1 : C WRMTIK SOURCE MAGN 09/07/30 21:21:14 6458 2 : SUBROUTINE WRMTIK(IFSAU,ITLACC,IMAX1,IFORM,IDEB) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C*********************************************************************** 6 : C NOM : WRMTIK 7 : C DESCRIPTION : Ecriture des objets de type MATRIK sur le 8 : C fichier IFSAU 9 : C (appelé par wrpil.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) : ECDIFE (ecriture d'un tableau d'entiers) 16 : C ECDIFR (ecriture d'un tableau de REAL*8) 17 : C ECDIFM (ecriture d'un tableau de CHARACTER*4) 18 : C*********************************************************************** 19 : C SYNTAXE GIBIANE : SAUV 20 : C ENTREES : IFSAU, numéro du fichier en écriture 21 : C IDEB, IMAX1, indice de début et de fin 22 : C de la pile des objets MATRIK (ITLACC) 23 : C à écrire. 24 : C IFORM, le fichier a ecrire est formaté ou 25 : C non. 26 : C*********************************************************************** 27 : C VERSION : v1, 15/07/98, version initiale 28 : C HISTORIQUE : v1, 15/07/98, création 29 : C HISTORIQUE : 30 : C HISTORIQUE : 31 : C*********************************************************************** 32 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 33 : C en cas de modification de ce sous-programme afin de faciliter 34 : C la maintenance ! 35 : C*********************************************************************** 36 : -INC CCOPTIO 37 : -INC SMMATRIK 38 : -INC TMCOLAC 39 : SEGMENT/ITBBM1/( ITABM1(NM)) 40 : C 41 : INTEGER NDTAB 42 : INTEGER IEL,I,J,K,L 43 : INTEGER ILENA(11) 44 : INTEGER IV1,IV2,IV3,IV4 45 : C====================================================================== 46 : * 47 : * Executable statements 48 : * 49 : C 50 : C ... BOUCLE SUR LES MATRIK DE LA PILE 51 : NM=0 52 : SEGINI ITBBM1 53 : DO 1 IEL=IDEB,IMAX1 54 : MATRIK=ITLAC(IEL) 55 : IF (MATRIK.EQ.0) THEN 56 : WRITE(IOIMP,*) 'Failing to save a nil pointer' 57 : WRITE(IOIMP,*) 'MATRIK type object...' 58 : GOTO 9999 59 : ENDIF 60 : C.... On initialise des piles d'objets non connus de CASTEM 61 : C MINC, PMORS, IZA, IDMAT 62 : C (Pb : des entiers distincts (par ex. KISPGP, KISPGT) 63 : C peuvent etre egaux (i.e. pointer sur le meme objet) 64 : C On ne veut pas sauvegarder l'objet deux fois...) 65 : SEGINI ITLAC1 66 : SEGINI ITLAC2 67 : SEGINI ITLAC3 68 : SEGINI ITLAC4 69 : C Sauvegarde du chapeau 70 : C Dimensions 71 : SEGACT MATRIK 72 : NRIGE =IRIGEL(/1) 73 : NMATRI=IRIGEL(/2) 74 : NKID=KIDMAT(/1) 75 : NKMT=KKMMT(/1) 76 : ILENA(1)=NRIGE 77 : ILENA(2)=NMATRI 78 : ILENA(3)=NKID 79 : ILENA(4)=NKMT 80 : NDTAB=4 80 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 81 : C Rigidités élémentaires 82 : NDTAB = NRIGE * NMATRI 82 : CALL ECDIFE(IFSAU,NDTAB,IRIGEL,IFORM) 83 : C Matrice assemblée 84 : ILENA( 1)=KSYM 85 : ILENA( 2)=KMINC 86 : ILENA( 3)=KMINCP 87 : ILENA( 4)=KMINCD 88 : ILENA( 5)=KIZM 89 : ILENA( 6)=KISPGT 90 : ILENA( 7)=KISPGP 91 : ILENA( 8)=KISPGD 92 : ILENA( 9)=KNTTT 93 : ILENA(10)=KNTTP 94 : ILENA(11)=KNTTD 95 : NDTAB=11 95 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 96 : NDTAB=NKID 96 : CALL ECDIFE(IFSAU,NDTAB,KIDMAT,IFORM) 97 : NDTAB=NKMT 97 : CALL ECDIFE(IFSAU,NDTAB,KKMMT,IFORM) 98 : C Sauvegarde des IMATRI 99 : DO 11 I=1,NMATRI 100 : IMATRI=IRIGEL(4,I) 101 : IF (IMATRI.NE.0) THEN 102 : SEGACT IMATRI 103 : NBSOUS=LIZAFM(/1) 104 : NBME=LIZAFM(/2) 105 : ILENA(1)=NBSOUS 106 : ILENA(2)=NBME 107 : NDTAB=2 107 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 108 : NM=4*NBME 109 : SEGADJ ITBBM1 110 : DO 111 J=1,NBME 111 : J4=(4*J)-3 112 : READ (LISPRI(J),FMT='(2A4)') ITABM1(J4),ITABM1(J4+1) 113 : READ (LISDUA(J),FMT='(2A4)') ITABM1(J4+2),ITABM1(J4+3) 114 : 111 CONTINUE 114 : CALL ECDIFM(IFSAU,NM,ITABM1,IFORM) 115 : NDTAB=NBSOUS*NBME 115 : CALL ECDIFE(IFSAU,NDTAB,LIZAFM,IFORM) 116 : ILENA(1)=KSPGP 117 : ILENA(2)=KSPGD 118 : NDTAB=2 118 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 119 : C Sauvegarde des IZAFM 120 : DO 112 K=1,NBME 121 : DO 1121 L=1,NBSOUS 122 : IZAFM=LIZAFM(L,K) 123 : IF (IZAFM.NE.0) THEN 124 : SEGACT IZAFM 125 : NBEL=AM(/1) 126 : NP =AM(/2) 127 : MP =AM(/3) 128 : ILENA(1)=NBEL 129 : ILENA(2)=NP 130 : ILENA(3)=MP 131 : NDTAB=3 131 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 132 : NDTAB=NBEL*NP*MP 132 : CALL ECDIFR(IFSAU,NDTAB,AM,IFORM) 133 : SEGDES IZAFM 134 : ENDIF 135 : 1121 CONTINUE 136 : 112 CONTINUE 137 : SEGDES IMATRI 138 : ENDIF 139 : 11 CONTINUE 140 : C Sauvegarde des MINC 141 : IV1=KMINC 142 : IF (IV1.NE.0) THEN 142 : CALL AJOUN2(ITLAC1,IV1) 143 : ENDIF 144 : JMINC=IV1 145 : IV1=KMINCP 146 : IF (IV1.NE.0) THEN 146 : CALL AJOUN2(ITLAC1,IV1) 147 : ENDIF 148 : JMINCP=IV1 149 : IV1=KMINCD 150 : IF (IV1.NE.0) THEN 150 : CALL AJOUN2(ITLAC1,IV1) 151 : ENDIF 152 : JMINCD=IV1 153 : NBMINC=MAX(JMINC,JMINCP,JMINCD) 154 : ILENA(1)=NBMINC 155 : ILENA(2)=JMINC 156 : ILENA(3)=JMINCP 157 : ILENA(4)=JMINCD 158 : NDTAB=4 158 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 159 : DO 12 I=1,NBMINC 160 : MINC=ITLAC1.ITLAC(I) 161 : SEGACT MINC 162 : NPT=MPOS(/1) 163 : NBI=MPOS(/2)-1 164 : ILENA(1)=NPT 165 : ILENA(2)=NBI 166 : NDTAB=2 166 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 167 : NM=2*NBI 168 : SEGADJ ITBBM1 169 : DO 121 J=1,NBI 170 : J2=(2*J)-1 171 : READ (LISINC(J),FMT='(2A4)') ITABM1(J2),ITABM1(J2+1) 172 : 121 CONTINUE 172 : CALL ECDIFM(IFSAU,NM,ITABM1,IFORM) 173 : NDTAB=NPT+1 173 : CALL ECDIFE(IFSAU,NDTAB,NPOS,IFORM) 174 : NDTAB=NPT*(NBI+1) 174 : CALL ECDIFE(IFSAU,NDTAB,MPOS,IFORM) 175 : SEGDES MINC 176 : 12 CONTINUE 177 : C Sauvegarde des PMORS 178 : IV2=KIDMAT(4) 179 : IF (IV2.NE.0) THEN 179 : CALL AJOUN2(ITLAC2,IV2) 180 : ENDIF 181 : JMORS=IV2 182 : IV2=KIDMAT(6) 183 : IF (IV2.NE.0) THEN 183 : CALL AJOUN2(ITLAC2,IV2) 184 : ENDIF 185 : JMRST=IV2 186 : NBMORS=MAX(JMORS,JMRST) 187 : ILENA(1)=NBMORS 188 : ILENA(2)=JMORS 189 : ILENA(3)=JMRST 190 : NDTAB=3 190 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 191 : DO 13 I=1,NBMORS 192 : PMORS=ITLAC2.ITLAC(I) 193 : SEGACT PMORS 194 : NTT=IA(/1)-1 195 : NJA=JA(/1) 196 : ILENA(1)=NTT 197 : ILENA(2)=NJA 198 : NDTAB=2 198 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 199 : NDTAB=NTT+1 199 : CALL ECDIFE(IFSAU,NDTAB,IA,IFORM) 200 : NDTAB=NJA 200 : CALL ECDIFE(IFSAU,NDTAB,JA,IFORM) 201 : SEGDES PMORS 202 : 13 CONTINUE 203 : C Sauvegarde des IDMAT (faite avant les IZA 204 : C car IDIAG pointe sur un IZA) 205 : IV4=KIDMAT(1) 206 : IF (IV4.NE.0) THEN 206 : CALL AJOUN2(ITLAC4,IV4) 207 : ENDIF 208 : JDMATP=IV4 209 : IV4=KIDMAT(2) 210 : IF (IV4.NE.0) THEN 210 : CALL AJOUN2(ITLAC4,IV4) 211 : ENDIF 212 : JDMATD=IV4 213 : NBIDMA=MAX(JDMATP,JDMATD) 214 : ILENA(1)=NBIDMA 215 : ILENA(2)=JDMATP 216 : ILENA(3)=JDMATD 217 : NDTAB=3 217 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 218 : C Sauvegarde des IZA 219 : IV3=KIDMAT(3) 220 : IF (IV3.NE.0) THEN 220 : CALL AJOUN2(ITLAC3,IV3) 221 : ENDIF 222 : JS2B=IV3 223 : IV3=KIDMAT(5) 224 : IF (IV3.NE.0) THEN 224 : CALL AJOUN2(ITLAC3,IV3) 225 : ENDIF 226 : JISA=IV3 227 : IV3=KIDMAT(7) 228 : IF (IV3.NE.0) THEN 228 : CALL AJOUN2(ITLAC3,IV3) 229 : ENDIF 230 : JIST=IV3 231 : IV3=KKMMT(4) 232 : IF (IV3.NE.0) THEN 232 : CALL AJOUN2(ITLAC3,IV3) 233 : ENDIF 234 : JZDU=IV3 235 : IV3=KKMMT(5) 236 : IF (IV3.NE.0) THEN 236 : CALL AJOUN2(ITLAC3,IV3) 237 : ENDIF 238 : JZDP=IV3 239 : IV3=KKMMT(6) 240 : IF (IV3.NE.0) THEN 240 : CALL AJOUN2(ITLAC3,IV3) 241 : ENDIF 242 : JZFU=IV3 243 : IV3=KKMMT(7) 244 : IF (IV3.NE.0) THEN 244 : CALL AJOUN2(ITLAC3,IV3) 245 : ENDIF 246 : JZFP=IV3 247 : NBIZA=MAX(JS2B,JISA,JIST,JZDU,JZDP,JZFU,JZFP) 248 : C On sauvegarde les IZA contenus dans les IDMAT 249 : DO 16 I=1,NBIDMA 250 : IDMAT=ITLAC4.ITLAC(I) 251 : SEGACT IDMAT*MOD 252 : NBLK=IDESCL(/1) 253 : C IDIAG 254 : IV3=IDIAG 255 : IF (IV3.NE.0) THEN 255 : CALL AJOUN2(ITLAC3,IV3) 256 : NBIZA=MAX(NBIZA,IV3) 257 : ENDIF 258 : IDIAG=IV3 259 : C IDESCL 260 : DO 161 J=1,NBLK 261 : IV3=IDESCL(J) 262 : IF (IV3.NE.0) THEN 262 : CALL AJOUN2(ITLAC3,IV3) 263 : NBIZA=MAX(NBIZA,IV3) 264 : ENDIF 265 : IDESCL(J)=IV3 266 : 161 CONTINUE 267 : C IDESCU 268 : DO 162 J=1,NBLK 269 : IV3=IDESCU(J) 270 : IF (IV3.NE.0) THEN 270 : CALL AJOUN2(ITLAC3,IV3) 271 : NBIZA=MAX(NBIZA,IV3) 272 : ENDIF 273 : IDESCU(J)=IV3 274 : 162 CONTINUE 275 : SEGDES IDMAT 276 : 16 CONTINUE 277 : DO 15 I=1,NBIDMA 278 : IDMAT=ITLAC4.ITLAC(I) 279 : SEGACT IDMAT 280 : NTT =KZA(/1) 281 : NPT =NUAN(/1) 282 : NBLK=IDESCL(/1) 283 : ILENA(1)=NTT 284 : ILENA(2)=NPT 285 : ILENA(3)=NBLK 286 : ILENA(4)=IDIAG 287 : NDTAB=4 287 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 288 : NDTAB=NTT 288 : CALL ECDIFE(IFSAU,NDTAB,KZA,IFORM) 289 : NDTAB=2*NTT 289 : CALL ECDIFE(IFSAU,NDTAB,NUIA,IFORM) 290 : NDTAB=NPT 290 : CALL ECDIFE(IFSAU,NDTAB,NUAN,IFORM) 291 : NDTAB=NPT 291 : CALL ECDIFE(IFSAU,NDTAB,NUNA,IFORM) 292 : NDTAB=NBLK 292 : CALL ECDIFE(IFSAU,NDTAB,IDESCL,IFORM) 293 : NDTAB=NBLK 293 : CALL ECDIFE(IFSAU,NDTAB,IDESCU,IFORM) 294 : NDTAB=NBLK+1 294 : CALL ECDIFE(IFSAU,NDTAB,NLDBLK,IFORM) 295 : SEGDES IDMAT 296 : 15 CONTINUE 297 : ILENA( 1)=NBIZA 298 : ILENA( 2)=JS2B 299 : ILENA( 3)=JISA 300 : ILENA( 4)=JIST 301 : ILENA( 5)=JZDU 302 : ILENA( 6)=JZDP 303 : ILENA( 7)=JZFU 304 : ILENA( 8)=JZFP 305 : NDTAB=8 305 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 306 : DO 14 I=1,NBIZA 307 : IZA=ITLAC3.ITLAC(I) 308 : SEGACT IZA 309 : NBVA=A(/1) 310 : ILENA(1)=NBVA 311 : NDTAB=1 311 : CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) 312 : NDTAB=NBVA 312 : CALL ECDIFR(IFSAU,NDTAB,A,IFORM) 313 : SEGDES IZA 314 : 14 CONTINUE 315 : C Restauration des pointeurs des IZA dans IDMAT 316 : DO 17 I=1,NBIDMA 317 : IDMAT=ITLAC4.ITLAC(I) 318 : SEGACT IDMAT*MOD 319 : NBLK=IDESCL(/1) 320 : C IDIAG 321 : IV3=IDIAG 322 : IF (IV3.NE.0) IDIAG=ITLAC3.ITLAC(IV3) 323 : C IDESCL 324 : DO 171 J=1,NBLK 325 : IV3=IDESCL(J) 326 : IF (IV3.NE.0) IDESCL(J)=ITLAC3.ITLAC(IV3) 327 : 171 CONTINUE 328 : C IDESCU 329 : DO 172 J=1,NBLK 330 : IV3=IDESCU(J) 331 : IF (IV3.NE.0) IDESCU(J)=ITLAC3.ITLAC(IV3) 332 : 172 CONTINUE 333 : SEGDES IDMAT 334 : 17 CONTINUE 335 : SEGDES MATRIK 336 : SEGSUP ITLAC4 337 : SEGSUP ITLAC3 338 : SEGSUP ITLAC2 339 : SEGSUP ITLAC1 340 : 1 CONTINUE 341 : SEGSUP ITBBM1 342 : * 343 : * Normal termination 344 : * 345 : RETURN 346 : * 347 : * Format handling 348 : * 349 : * 350 : * Error handling 351 : * 352 : 9999 CONTINUE 353 : WRITE(IOIMP,*) 'An error was detected in subroutine wrmtik' 354 : RETURN 355 : * 356 : * End of subroutine WRMTIK 357 : * 358 : END 359 : 360 : 361 : 362 : 363 : 364 : 365 : 366 : 367 : 368 :
© Cast3M 2003 - All rights reserved.
Disclaimer